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2 Pascal programs 


QO. Preface 


This is a collection of a wide variely of Pascal programs. They range in complexily 
from simple examples used in introductory courses to illustrate design principles and 
language features to intricale examples discussed in courses on algorithms and data 
structures. The programs, however, are grouped according to subject malter rather 
than complexity. Many are taken from the literature listed below, where they are 
explained and analyzed in detail. 


The main purpose of this booklet is to provide the teacher of programming with a 
condensed collection of exemplary programs and thereby to exhibil a preferred slyle 
of programming using a structured language. At the same time, the booklet may serve 
as a guide in inventing other, perhaps similar exercises. Lastly, it may be a helpful 
reference to some widely used, fundamental algorithiris, formulated in detail in a 
widely available language. 


References 
N. Wirth, Systemalic programming. Prentice-llall, Inc. 1973. 


-- Algorithms + data structures = programs. Prentice-Hall, Inc. 1975. 
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1. Integer arithmetic 


1. Raise integer to a positive power. Repeat reading pairs of integers, until you 
encounter a Q. Indicate invariant of Joop. 


PROGRAM power(input, output); 
VAR a, b: integer; 


FUNCTION power (x,n: integer): integer; 
VAR w,z,i: integer; 
BEGIN wis x;iis nj zis; 
WHILE i # 0 DO 
BEGIN (* z*wrti = xtn *) 
IF odd(i) THEN z := z*w; 


w t= sar(w); i := i DIV 2 
END; 
power ‘= Z 


END (* power *) ; 


BEGIN read(a); 
WHILE a # 0 DO 
BEGIN read(b); writeln(a, b, power(a,b)); 
read(a) ; 
END 
END . 


2. Divide an integer by a natural number, using operations of addition, subtraction, 
doubling and halving only. Repeat reading pairs of integers, until you encounter a QO. 


For each pair, print dividend, divisor, quolient, and remainder. Indicate invariant of 
loop. 


PROGRAM divide(input, output); 
VAR a,b,q,r: integer; 


PROCEDURE divide (x,y: integer; VAR z,a: integer); 
VAR q,r,w: integer; 
BEGIN r is xX; w i= y; q t= 0; 
WHILE w <= r DO wis 2*w; 
WHILE w # y DO 
BEGIN (* x = q'we+r*) wesw DIV 2; qi= 2°q; 
IF w <= ¢ THEN 
BEGIN r := r-w; q is qt 
END 
END ; 
Zin qpaisr 
END (*divide*) ; 


BEGIN read(a); 
WHILE a # 0 DO 
BEGIN read(b); divide(a,b,g,r); writeln{a, b, q, r); 
read(a) 
END 
END . 
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3. Compute the greatest common divisor (gcd) and the lowest common multiple (lcm) 
of two natural numbers by using addilion and subtraction only. Note that gcd(m,n) * 
Icm(m,n} = m*n, Repeat reading pairs of integers, until you encounter a 0. For each 
pair, print the arguments, the gcd and the tcm. Indicate the toop invariant. 


PROGRAM gcdlem(input, output); 
VAR a,b,c,d: integer; 


PROCEDURE gcd(x,y: integer; VAR u,v: integer); 
VAR a,b,c¢,d: integer; 
BEGIN a := x; c t= x; b t= y; die y; 
WHILE a # b DO 
BEGIN (*gcd(a,b) = gcd(x,y) AND a*d + b*’c = 2*x*y*) 
IF a > b THEN 
BEGIN a := a-b; ¢ := c+d 
END 
ELSE 
BEGIN b := b-a; d: 
END 
END ; 
U ts aj v i= (c+d) DIV 2 
END (*gcdmult*) ; 


d+c 


BEGIN read(a); 
WHILE a # 0 DO 
BEGIN read(b); gcd(a,b,c,d); writein(a, b, c, d); 
read(a) 
END 
END . 


4. Compute the greatest common divisor (gcd) of two natural numbers. Use addition, 
subtraclion, doubling and halving only. 


PROGRAM binarygcd(output); 
VAR a,b: integer; 


FUNCTION ged (x,y: integer): integer; 
VAR u,v,d, a,b,k: integer; 
BEGIN u := x; v i= y; a t= 0; b cts 0; 
WHILE NOT odd(u) DO 
BEGIN u:s u DIV 2; a c= art 
END ; 
WHILE NOF odd(v) DO 
BEGIN v := v DIV 2: b := b+1 
END ; 
IF a¢b THEN k := a ELSE k := b; 
dtsu-v; 
WHILE d #0 DO 
BEGIN REPEAT d := d DIV 2 UNTIL odd(d); 
Vv: 


IF d<O THEN = -d ELSE u:= d; 
d:izu-v 

END ; 

WHILE k>O DO 

BEGIN u t= 2tu; k t= k-4 

END; 

gcd := u 


END ; 
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BEGIN read(a); 
WHILE a # 0 DO 
BEGIN read(b); writeln(a, b, gcd(a,b)); read(a) 
END 

END . 


5. Compute the largest integer less or equal to the square root of a given integer 
(due to Hoare). 


PROGRAM isart(input,output); 
VAR n,a2,b2,ab,t: integer; 
BEGIN read(n); 
WHILE n >= 0 DO 
BEGIN a2 := 0; ab := 0; b2 := 1; writeln(" n = 
WHILE b2 <= n DO b2 := 4%b2: - 
WHILE b2 # 1 DO 
BEGIN (* a2+2*ab+b2 > n, O <= a2 <= n, sar{ab) = a2*b2 *) 
ab := ab DIV 2; b2 := b2 DIV 4; t t= a2 + 2*ab + b2; 


»n); 


IF t <= n THEN 
BEGIN a2 := t; ab := ab + b2; 
END 
END ; 
writeln(a2,ab,b2); read(n) 
END 


END . 
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2. Integer arithmetic and arrays 


1. Find all integers belween 1 and 1000 whose squares are palindromes. 


1172 = 121, 2272 = 484, 


PROGRAM palindromes(output); 
VAR i,j,|.n r,s: integer; 
p: boolean; 
d: ARRAY [1..10] OF integer; 
BEGIN n t= Oy 
REPEAT n: Lia Sis n*n; 
REPEAT ; t= ; fis 
d[!] := s - 
UNTIL S = 6 
= |; 


; j: 
REPEAT p : o dCi]; 
iis i+; jus j-1 
UNTIL (i>=j) OR NOT p; 
IF p THEN writeln(n,n*n) 
UNTIL n = 1000 
END . 


2. Compute and print magic squares of order 3, 5, 7, ... 


PROGRAM magicsquare(oulput); 
CONST lim = 11; 
VAR i,j,x,nx,nsq,n: integer; 
m: ARRAY [(1..lim,1.Jim] OF integer; 


PROCEDURE getsquare; 
- BEGIN x := 0; nsq := sqr(n); 
= (n+1) DIV 2; j t= n+1; 
REPEAT nx t= x + n; j 7s j-1; 
K t= x41; MELP] c= x; 
REPEAT i := i+1; IF i > n THEN i c= 
= j+1; IF j > n THEN j:= 1; 
x t= x+t; mij] c= x 


1; 


UNTIL x = nsq 
END (‘getsquare*) ; 


PROCEDURE printsquare; 
BEGIN 
FOR its 1 TO n DO 
BEGIN FOR j := 1 TO n DO write(m{ij]: 6); 
writeln 
END ; 
wrileln 
END (*printsquare*) ; 


BEGIN n z= 3; 
REPEAT gelsquare; printsquare; n := n+2 
UNTIL n > lim 

END . 


Examples: 
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3. Compute a table of positive and negative powers of 2. Exponents range from 1 to, 
say, 64. Do not truncate any digits! 


PROGRAM powersoftwo(output); 
CONST m = 31; n = 100; (* m = ntlog(2) *) 
VAR exp,ij,: integer; 
crt: integer; 
d: ARRAY [0..m] OF integer; (*positive powers*) 
f: ARRAY [1..n] OF Wee (‘negative powers’) 
BEGIN |: =O ‘ t= t; d[O] := 
FOR exp : 1TOn DO 
BEGIN (Cc compute and print 2**texp *) c i= 0; 
FOR i := 0 TO 100 
BEGIN t := 2*df[i] + ¢; 
IF t >= 10 THEN 
BEGIN d[i] := t-10; c t= 1 


END 
ELSE 
BEGIN d[i] := = 0 
END 
END ; 
IF c > O THEN 
BEGIN | := 141; d[I] := 1 
END ; 
FOR i := m DOWNTO | DO write(" "); 
FOR i := | DOWNTO O DO write(d{i]:1); 
write(exp:5, "— ."); 


(*compute and print oee(- exp) *) 
FOR j tO ep 0 
BEGIN r:t= 10°r + f[j]; 
f[j] c= r DIV 2; rier - 2*tCj]; write({Lj]:1) 


fLexp] := 5; writeln("5"); r i= 0 
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4, Compute a table of exact fractions 1/2, 1/3, .., 1/64. If the fraction has a period, 
print an apostrophe in front of its first digit and truncate after its last digit. 


PROGRAM [ractions(output); 
(* fractions to the base b *) 
CONST b = 10; max = 64; 
VAR i,t,n.q.r: integer; 
a, f: ARRAY [0..max] OF integer; 
BEGIN FOR n := 2 TO max DO 
BEGIN | t= O; r i= 1; 
FOR i := 0 TO n-1 DO afi] := 0; 
REPEAT 1 := +4; afr] := 
res btr; gis r OV np rcs r - g*tn; (Ll c= 
UNTIL a[r] # 0; 
write(n, " "| "."); 
FOR i := 1 TO af{rj-1 DO write(f[iJ:1); 
IF afr] > 1 THEN write(""""); 
FOR i:= a[r] TO! DO write(f[iJ:1); 
writeln 
END 
END . 


5. Compute the harmonic function H(n) = 1+ 1/2 + 1/3 + .. + 1/n with m digits 
accuracy. 


PROGRAM harmonic(input,output); 
CONST lim = : 
VAR i,k,m,n,c,r,g,sum: integer; 
d,s: ARRAY [0..lim] OF integer; 
BEGIN read(m,n); 
IF (m>Q) AND (m<lim) THEN 
BEGIN d[O] := 0; s[O] := 
FOR i := 1 TO m DO S[i] := 0; 
FOR k := 2 TO nDO 
BEGIN (*compute 1/k)* r c= 1 
FOR i := 1 TO m DO 
BEGIN r c= 10%r; q i= r DIV kj t= r-q*k; dLi] c= 
END ; 
IF (10*r DIV k) >= 5 THEN d[m] := alm] +4; (*round)* 
write(" 0."); (*intermediate output*) 
FOR i := 1 TO m DO write(d[iJ:1); 
writeln; 
(*compute s t= s + 1/k)* cits 0; 
FOR i := m DOWNTO 0 DO 
BEGIN sum := sfi]+d[iJ+c; 
IF sum >= 10 THEN 
BEGIN sum <= sum-10; c t= 1 


' 


END 
ELSE c := 0; 
s[i] := sum 
END 


write(" ", s[O}:1, ".") 
FOR i:='1 TOm oo ‘write(sfil: 1); 
writein 
END 
END . 
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6. Compute a table of the first n prime numbers. Print m numbers per line. 


PROGRAM primes(outpul); 
CONST n = 1000; n1 = 33; m = 20; (*n1 ~ sqri(n)*) 
VAR i,k,x,inc,lim,square,|: integer; 
prim: boolean; 
pv: ARRAY [1..n1] OF integer; 
BEGIN | := 0; 
X i= 1; inc := 4; lim := 1; square := 9; 
FOR i:= 3 TOn DO 
BEGIN (*find next prime‘) 
REPEAT x := x+inc; inc := 6-inc; 
IF square <= x THEN 
BEGIN fim := lim+1; 
v[lim] := square; square := sqr(p[lim+1]) 
END ; 
k := 2; prim := true; 
WHILE prim AND (k<lim) DO 
BEGIN k := k+1; 
IF v[k] < x THEN v[k] := v[k] + 2*p[k]; 
prim := x # v[k] 
END 
UNTIL prim; 
IF i <= nt THEN pf[i] := x; 
write(x:6); I ss l+4; 
IF 1} = m THEN 
BEGIN writeln; | := 0 
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7. Compute a table of the first n prime numbers. Print m numbers per line. Use the 
method of the sieve of Eratosthenes. 


PROGRAM primes(output); 
CONST m = 100; n = 10000; m = 20; h = 58; 
VAR x, inc, i,k, x1,x2, lim, square, a,b,k integer; 
pv: ARRAY [1..m] OF integer; 
sieve: SET OF 0..h; 
BEGIN | := 0; 
X is 1; inc c= 4; lim := 1; square := 9; 
x1 := 0; x2 := 0; sieve := [0..h]; 
pli} := 2; p[2] := 3; 
FOR ij := 3 TOn DO 
BEGIN (‘find next prime)* 
REPEAT x := x+inc; inc := 6-inc; 
IF x >= square THEN 
BEGIN lim := lim+1; a := square; b := 2*p[lim]; 
WHILE a < x2 DO 
BEGIN sieve := sieve - [a-x1]; a :s a+b 
END ; 
v[lim] := a; square := sqr(p[lim+1]) 
END ; 
IFeox >= x2 THEN 
BEGIN (*consiruct new sieve)* 
X1 t= x2; x2 t= x2+h; sieve := [0..h]; 
FOR k := 3 TO lim DO 
BEGIN a := v[k]; b t= 2*p[k]; 
WHILE a < x2 DO 
BEGIN sieve := sieve - [a-xi]; a := a+b 
END ; 
v[k] := a 
END 
END : 
UNTIL x-x1 IN. sieve; 
IF i <= m THEN pfi] := x; 
write(x:6); bss 141; 
IF | = m THEN 
BEGIN writeln; I := 0 
END 
END ; 
writeln 
END. 
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3. Real (floating point) arithmetic 


1. Compute the sum 1 - 1/2 + 1/3 - 1/4 + .. - 1710000 in four different ways: 
1. proceed strictly from left to right, 
2. sum positive and negative terms separately, 
3. proceed strictly from right to left, 
4. as in 2., but from right to left. 
Explain the differences in the results. 


PROGRAM sum10000(output); 
CONST n = 10000; 
VAR i: integer; x, y, s1, s2p, s2n: real; 
BEGIN i := 1; 
s{ t= 0; s2p := 0; s2n := O; 
REPEAT x := 1.0/i; y := 1.0/(i+1); 
str=si+x-y; 
Sep := S2p + x; s2n i= s2n + y; 
iis i+#2 
UNTIL i > 1; 
write (s1, S2p-s2n); 
[ian 


$1 := 0; s2p := OG; s2n := O; 

REPEAT x := 1.0/(i-1); y t= 1.07%; 
Slisst+x- y; 
S2p i= S2p + x; s2n t= s2n + y; 
iis f-2 

UNTIL i = 0; 

writein(s1, s2p-s2n) 


END . 


2. Multiply lhe complex number z = 5/13 + 12/13i 


50 times with the complex 
number w = (0.6 + 0.8i). Print intermediate products and the square of their absolute 
value. Note that [z|] = |w| = 1. 


PROGRAM complexmull(output); 
CONST u = 0.6; v = 0.8; 
VAR i,j: integer; x,x1,y: real; 
BEGIN x := 5/13; y := 12/13; 
FOR i:= 1 TO 50 DO 
BEGIN FOR j := 1 TO 10 DO 
BEGIN (* (x+iy) := (x<tiy) * (utiv) *) 
Xl c= x*u > y'v; y c= ytu + xty; x 
END ; 


writeln(x,y,sqr(x)+saqr(y)) 


‘2 xT 


END 
END . 


im 
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3. Compute the Fibonacci numbers F(1) .. F(N) in two different ways: 
1. By repeated addition according to F(n) = F(n-1) + F(n-2), F(O) = F(4) = 1, 
2. Using the formula F(n) ~ (phitn)/sqrt(5), where phi = (1+sqrt(5))/2. 
Terminate as soon as the two results differ. 


PROGRAM fibonacci(output); 
CONST rootS = 2.236068; 
VAR i, fibO, fib1, fib3, t: integer; 
phi,fib2: real; 
BEGIN phi := (1.0+root5)/2; 
its O; fibO := 4; fib1 := 0; fib2 := 1.0 / roots; 
REPEAT i := i+1; 
t:= fibO+fib1; fibO := fib1; fib1 := t 
fib2 := fib2 * phi; fib3 := trunc(fib2 + 0.5); 
writeln(i, fib1, fib3) 
UNTIL fib1 # fib3 
END . 
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4. Analytic functions and iteration 
CONST eps = 1&-8; 


FUNCTION sart (x:real): real; 
VAR a,c: real; (* O<x<2 *) 
BEGIN a t= x; c t= 1.0-x: (* abs(c)<1 *) 
REPEAT (* at2 = b*(1-c) => (a*(1+c/2))t2 = b*(1-c)* (t+c/2)t2 = 
mF (1-0.75*(ct2) - 0.25*(ct3)) *) 


acts at(1.0 + 0.5%c); 
(* ar2 = b*(1-0.75*(ct2) - 0.25*(ct3)) = 
= b*(1-(ct2)*(0.75 + 0.25*c) *) 

c :=s sqr(c) * (0.75 + 0.25%); 


(* at2 = b*(1-c) *) 
UNTIL abs(c) < eps; 
sqrt i= 
END ; 


FUNCTION log (x: real): real; 
VAR a,b,s: teal; (* 1<=x<2 *) 
BEGIN a := x; b t= 1.0; 5 := 0; 
eee (* log(x) = S$ + b*log(a), b<=1, 1<=a¢2 *) 
26 al (* log(x) = s + b*log(sqrt(a)), 1<=a¢4 *) 
b t= 0.5*b; (* log(x) = s + b*log(a) *) 
IF a >= 2.0 THEN 
BEGIN (* 2<a<4 *) s t= stb (* log(x) = s + (1-b)*log(a) *); 
= 0.5'a 
END 
UNTIL abs(b) < eps; 
log := 
END ; 


FUNCTION recip (x: real): real; 
VAR a,c: real; (* O<x¢<2 *) 
BEGIN a := 1.0; - <= 10- x; 
REPEAT (* a*x = 1-c, abs(c)<1 *) 
acs a*(1 Ore). (* x*a s (1-c)*(1+c) = 1 - cr2 *) 
c != sar(c); (* xta = 1-c *) 
UNTIL abs(c) < eps; 
recip := a (* recip = 1/x *) 
END ; 


14. 
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Compute anafytic functions as truncated sums. Determine the recurrence relations of 
their terms. 


PROGRAM recurrence(input,output); 
VAR i,n: integer; x,y,s,t real; 

BEGIN 

writeln(" exp"); n t= 5; 

REPEAT eo yi 1 


.O; | := OF t t= 1.0; 
REPEAT i := i+1; t t= xvi 
yrs y + t 
UNTIL y+t = y; 
writeIn(x,y,i); nots n-1 
UNTIL n = 0; 


REPEAT read(x); y 


writetn(" sin"); nis 5; 
REPEAT i: tee: t: 


Xi its 1; s := sqr(x); t i= x; 
ts -ts/((i- 1)" 1); 
yiznyet 

UNTIL y+t = y; 

ee i DIV 2); nz n-1 
UNTIL n = 


writeln(" cos"); n t= 5; 
REPEAT read(x); y t= 1.0;-i :s 0; s := sar(x); t: 
REPEAT f t= i+2; t t= -t*s/((i-1)*i); 
yisyrtt 
UNTIL y+t = 


writeln{x,y, | DIV 2); nc= n-1 
UNTIL n = Q; 


it 


1.0; 


writein(" arcsin"); n := 5; 
REPEAT ey 


i= xX} ; ts 1; 5 t= sar(x); t ts x 
REPEAT ft := ; t c= P*s*sqr(i-2)/((i- 1) *i); 
yrs y+ a 
UNTIL. y+t = 
writeln(x,y, | DIV 2); nis n-1 
UNTIL n = O; 


, 


writeln(" arctan"); n i= 5; 
REPEAT Sal y: 


t= xp bite 17 5 t= sar(x); t t= x; 
REPEAT i t= i+2; t c= -t*s*(i-2)/i; 
yrs y + t 
UNTIL y+t = y; 
writeln(x,y, i DIV 2); nis n-1 
UNTIL n = O; 


writeln(" In"); n:= 5; 


REPEAT at. x e x-1.0; yis xp tis ics 4; 
+1; tts 


REPEAT i := ~ttx*(i- 1) Zi; 
yrs y+ t 
UNTIL y+t = 
wrilein(x+1.0, y, i); nis n-1 
UNTIL n = O; 


END. 
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5. Text processing 


1. Plot the function f(x) = exp(-x) * cos(2*pitx) with your line printer in the range x 
= 0. 4. Use 32 lines for the unit coordinate. 


PROGRAM printerplot(output); 
CONST xscale = 32; 
yscale = 50; yshift = 65; 
twopi = 6.283183307 1796; 
VAR i,k,n: integer; 
x,y: real; 
BEGIN n:= 0; (* n= x position *) 
REPEAT x := n / xscale; 
y <= exp(-x)*cos(x*lwopi); k := round(y*yscale); 
i:= O; write(" "); (* i = no of chars in line *) 
IF k < 0 THEN 
BEGIN write(" ": yshift+k); write("*"); 
k := -k-1; IF k > O THEN write(" ":k); 
write("}") 
END ELSE 
BEGIN write(" ": yshift); 
IF k > O THEN 
BEGIN write("|"); k t= k-1; 
IF k > O THEN write(" ":k) 
END ; 
write("*") 
END ; 
writeln; n c= n+1 
UNTIL n > 96 
END . 


2. Read a text and count the number of words wilh length 1, 2, ... , 20, and those with 
length greater than 20. Words are separated by blanks or ends of lines. 


PROGRAM wordlengths(input,output); 
VAR i,k: inleger; 
ch: char; 
count: ARRAY [1..21] OF integer; 
BEGIN 
FOR i :=s 1 TO 21 DO count[i] := 0; 
WHILE NOT eof(input) DO 
BEGIN read(ch); 
IF ("a"<=ch) AND (ch¢="2") THEN 
BEGIN ("new word)?’ k := 0; 
REPEAT k := k+1; read(ch) 
UNTIL (ch<"a") OR ("z"<ch) ; 
IF k > 20 THEN k t= 21; 
counl[k] := count{k] + 1 
END 
END ; 
writeln; 
writeIn(” tength count"); 
FOR i t= 1 TO 21 DO writeln(i,count[i]) 
END . 
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3. Read a text and produce a copy with flushed lefl and right margins. Place a fixed 
number of characiers (say, length = 72) in each line, and distribute blanks as word 
. separators accordingly. 
PROGRAM edit(input,output); 
CONST length = 72 
VAR ch: char; 
iim,k,lim: integer; 
line: ARRAY [1..136] OF char; 
index: ARRAY [1., 68] OF integer; 


PROCEDURE setline; 
VAR i,j,h,s: integer; 
spaces, q,l,r: integer; 
BEGIN !F m=O THEN 
BEGIN (*word is longer than line)* m :=, 1; index[m] := lim 
END ; 
= O; write(" "); (*printer control)* 
IF m > 1 THEN 
BEGIN spaces := lim - index[m]; 
ae = spaces DIV (m-1); r := spaces - (m-1)*q; 
t= (m-r) DIV 2; rss ler;  ('distribute spaces)* 
t= QO; 
REPEAT i := i+1; s := index{i]; 
REPEAT ie I= = +4; write(line{jJ) 
UNTIL j = 
FOR h := ‘To q DO write(" "); 
IF (l<=i) AND (i<r) THEN write(" "); 
UNTIL i = m-1 
2 : 
§ t= index{m]} -1; 
oe he is je; write( linet) 
oe j = 
= 0; siaitelh 
FOR h := index[m]+1 TO lim DO 
BEGIN j := j+1; line[j] := line[h] 
END ; 
k t= jj mis O 
END (‘setline)* ; 


BEGIN lim := length+1; 
k := 0; (*k = no. OF characters IN tine)’ 
m:= 0; (*m = no. OF complete words IN line)* 
WHILE NOT eof{input) DO 
BEGIN read(ch); 
IF ch # " " THEN 
BEGIN (*next word)* 
REPEAT k := k+1; line[k] := ch; read(ch); 
IF k = lim THEN setline 
UNTIL ch = ""; 
k t= k+1; line{k] : oe 
m i= m+; index[ m] 1 ‘k: 
IF k = lim THEN selline 
END 
END ; 
write(" "); 
FOR i t= 1 TO k DO write(line[i]); 
writeln 
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END . 


4. Read a text and replace any sequence of one or more blanks by a single blank. 


PROGRAM crunch(input,outopul); 
CONST blank =" "; 
VAR ch: char; 
BEGIN 
WHILE NOT eof(input) DO 
BEGIN read(ch); write(blank); ‘(*printer control’) 
WHILE ch = blank DO read(ch); 
WHILE NOT eoln(input) DO 
BEGIN 
REPEAT write(ch); read(ch) 
UNTIL ch = blank; 
write( blank); 
WHILE (ch=blank) AND NOT eoin(input).DO read(ch) 
END ; 
writeIn; read(ch) 
END 
END 
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5. A record company conducts a poll to evaluate its products. The most popular hits 
are to be broadcast in a hit parade. The polled population is divided into four 
categories according to sex and age (teenager <= 20, adult > 20). Each person is 
asked to list five hits, identified by their number belween 1 and, say, 50. The result 
of the poll is presented as a file; each record lists a respondent's name, first name, 
sex, age, and his choices ordered according to priority. A program is to compute the 
following data: 


1. A list of hits ordered according to popularity. Each entry consists of the hit 
number and the number of votes it received. Hits not mentioned are omitted. 


2. Four separate lists with names and first names of all respondents who had 
mentioned in first place one of the three hits most popular in their calegory. 


PROGRAM hitparade(poll ,output); 
CONST n = 50; (* number of hits *) A 
TYPE sex = (male, female); , 
hitno = 1.71; 
query = RECORD 
name, firstname: alfa; 


$: Sex; 
age: O .. 99; 
choice: PACKED ARRAY [1..5]} OF hitno 
END ; 
VAR i,k,max: integer; 
b: boolean; 


total: ARRAY [hitno] OF integer; 
count: ARRAY [sex,boolean,hitno] OF integer; 
poll: FILE OF query; 


PROCEDURE findnames(x: sex; y: boolean); 
VAR i,j,k: integer; 
selection: SET OF hitno; 
BEGIN selection := []; reset(poll); 
WritelIn(" -----nn nen ne nnn nee nee nnn cee e cen n nen "); 
(* find 3 hits most frequently listed in this group *) 
FOR i := 1 TO 3 DO 
BEGIN max := 0; 
FOR j := 1 TOnDO 
IF max < count[x,y,j] THEN 
BEGIN max := count[x,y,jJ; k t= j 
END ; 
-selection := selection + [k]; count[x,y,k] := 0 
END ; 
(* list persons with one of these hits as first choice *) 
WHILE NOT eof(poll) DO 
BEGIN 
WITH polit DO 
IF s = x THEN 
IF (age >= 20) = y THEN 
IF choice[1] IN selection THEN 
writeln(" ",name,” " firstname); 
get(poll) 
END 
END (*findnames’) ; 


BEGIN reset(poll); 
FOR i:= 1 TO nDO 
BEGIN total[i] := 0; 
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* 
. 


count[male,true,i] := 0; count[female,true,i] := 0 
t= 0 


count[male,false,i] := 0; count[female,false,i] 
END ; 
{* collect counts *) 
WHILE NOT eof(poll) DO 
BEGIN 
WITH poillt DO 
FOR i:= 1 TO 5 DO 
BEGIN b := age >= 20; k := choice[i]; 
count(s,b,k] := count{s,b,k} + 1 
END ; 
gel(poll) 
END ; 
(* compute totals *) 
FOR i:= 1TOn DO 
total[i] := count[male,true,i] + count[female,true,i] 
+ count[male,faise,i] + count{ female, false,i]; 
page(output); 
writeIn(" report on hit popularity poll”): 
writeIn(” list of hits ordered after popularity"); 
writeln(" hit frequency”); 
REPEAT max := 0; k := 0; 
FOR i:= 1TOnDO 
IF max ¢< totalli] THEN 
BEGIN max := total[iJ; k := i 
END ; 
IF max > 0. THEN 
BEGIN total[k] := 0; writein(k, max) 
END ; 
UNTIL max = 0; 
writeln(" namelists separate by sex and age"); 
writein(" men"); findnames(male,true); 
writeln(" women"); findnames(female, true); 
writeln(" boys "); findnames(mate, false); 
writeIn(" girls"); findnames(female, false); 
writeln(" end of report") 
END . 
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6. Recursion 


1, Compute all ni permutations of the integers 1... 9 


PROGRAM permute(output); 
CONST n = 4; 
VAR i: integer; 
a: ARRAY [1..n] OF integer; 


PROCEDURE print; 
VAR i: inleger; 

BEGIN FOR i := 1 TO n DO write(afi):3); 
writeln 

END (*print*) ; 


PROCEDURE perm(k: integer); 
VAR i,x: integer; 
BEGIN 
IF k = 1 THEN print ELSE 
BEGIN perm(k- 1); 
FOR i t= 1 TO k-1 
BEGIN x := a[iJ; ati ce ak]; alk] := 
perm(k-1); 
x i= afi); afi] := alk]; alk] := x; 
END 
END 
END (*perm"*) ; 


BEGIN 
FOR i:s 1 TO n DO afi] := 
perm(n) 

END . 
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2. Convert expressions from infix to postfix form. Each expression is written on a 
separate line. Expressions have the following syntax: 


expression = term (("+"["=")} term}. 
term = factor ("*" factor}. 
factor = letter | "(" expression ")". 
PROGRAM postfix{input, output); 
VAR ch: char; 
PROCEDURE expression; 
VAR op: char; 


PROCEDURE factor; 
BEGIN IF ch = "(" THEN 
BEGIN read(ch); expression; read(ch) (* ) *) 
END ELSE 
BEGIN write(ch); read(ch) 
END 
END (* factor *) ; 
PROCEDURE term; 
BEGIN factor; 
WHILE ch = "*" DO 
BEGIN read(ch); factor; write("*") 
END 
END (* term *); 
BEGIN term; 
WHILE (ch="+") OR (ch="-") DO 
BEGIN op := ch; read(ch); term; write(op) 
END 
END (* expression *) ; 
BEGIN 
WHILE NOT eof(input) DO 
BEGIN write(""); read(ch); expression; writeln; readin 
END 
END . 
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3. Plot Hilbert curves of orders 1... n. Plot procedure produces output for the 
Tektronix 4010 terminal. Data are represented as 12-bit bytes: a call of procedure 
p12 appends a byte lo the output file. 


PROGRAM hilbert(pf,outpul); 
CONST n= 4; hO = 512; 
VAR i,h,x,y,x0,yO: integer; 
cc, wc, buf: integer; 
pf: FILE OF integer; (‘plot file*) 


PROCEDURE p12(u: integer); 
BEGIN buf := buf * 4096 + u; cc t= cco + 1; 
IF cc = 5 THEN 
BEGIN pft := buf; put(pf); 
we ‘= wo+t; buf := 0; cc := 0; 
IF we = 31 THEN 
BEGIN pft := 0; put(pf); we := 0 
END 
END 
END (*pi2*); 


PROCEDURE plot; 
VAR u,v: integer: 

BEGIN u := x DIV 32; v t= y DIV 32; 
p12(40b+v); p12(140b+y-32*v); 
pi2(40b+u); p12(100b+x-32"u); 

END (*plot*) ; 


PROCEDURE setplot; 
BEGIN p12(35b); plot 
END ; 


PROCEDURE startplot; ; 
BEGIN cc := 0; wo := 0; buf := 0; rewrite(pf) 
END ; 


PROCEDURE endplot; 

BEGIN x := 0; y := 767; setplot; p12(37b); 
REPEAT p12(0) UNTIL cc = 0 

D . 


PROCEDURE bf{i: integer); FORWARD; 
PROCEDURE c(i: integer); FORWARD; 
PROCEDURE d(i: integer); FORWARD; 


PROCEDURE a(i: integer); 
BEGIN IF i > O THEN 
BEGIN d(i-1); x := x-h; plot; 
a(i-1); y := y-h; plot; 
a{i-1); x t= x-+h; plot; 
b(i-1) 
END 
END ; 


PROCEDURE b; 
BEGIN IF ij > O THEN 
BEGIN c{i-1); y := y+h; plot: 
b(i-1); x := x+h; plot; 


Recursion 


b(i-1); y := y-h; plot; 
a(i-1) 
END 
END ; 


PROCEDURE oc; 


BEGIN IF i > 0 THEN 
BEGIN b(i-1); x 
c(i-i); y: 
c(i-1); x: 
d(i-1) 
END 
END ; 


PROCEDURE d; 
BEGIN IF i > O THEN 


BEGIN a(i-1); y : 


d(i-1); x 
d(i-1); y: 
c(i-1) 
END 
END ; 


BEGIN startplot; 


:= xth; plot; 
yth; plot; 
x-h; plot; 


uo 


y-h; plot; 


‘= x-h; plot; 
By 


+h; plot; 


i t= O; h := hO; xO := h DIV 2 +h; yO := h DIV 2; 
REPEAT (‘plot hilbert curve OF order i*) 
ics i441; h c= h Div 2; 
xO := x0 + (h DIV 2); yO := yO + (h DIV 2); 
x i= x0; y := yO; setplot; 
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4, Plot Sierpinski space-filling curves using their recursive pattern. Plot routine is 
identical to the one used in the preceding program. 


PROGRAM sierpinski(pf,output); 
CONST n= 4; hO = 512; 
VAR i,h,x,y,x0,yO: integer; 

cc, we, buf: integer; 

pf: FILE OF integer; (*plot file*) 


PROCEDURE p12(u: integer); 
BEGIN buf := buf * 4096 + u; cc ‘= cc + 1; 
IF cc = 5 THEN 
BEGIN pft := buf; put(pf); 
we ts wc+t1; buf := 0; cc t= 0; 
IF wo = 31 THEN 
BEGIN pft := 0; put(pf); we := 0 
END 
END 
END (*p12*) ; 


PROCEDURE plot; 
VAR u,v: integer; 

BEGIN u:= x DIV 32; v := y DIV 32; 
pi2(40b+v); p12(140b+y~-32*v); 
pi2(40b+u); pt2(100b+x-32*u); 

END (*plol*) ; 


PROCEDURE seiplol; 
BEGIN p12(35b); plot 
END ; 


PROCEDURE startplot; 
BEGIN cc := 0; wo := 0; buf := 0; rewrite(pf) 
END ; 


PROCEDURE endplot; 

BEGIN x := O; y := 767; setplot; p12(37b); 
REPEAT p12(0) UNTIL cc = 0 

END ; 


PROCEDURE b({i: integer); FORWARD; 
PROCEDURE c(i: integer); FORWARD; 
PROCEDURE d(i: integer); FORWARD; 


PROCEDURE a(i: integer); 
BEGIN IF i > O THEN 


BEGIN a(i-1); x t= x+h; y := y-h; plot; 
b(i-1); x := x + 2*h; plol; 
d(i-1); x := x+h; y := y+h; plot; 
a(i-1) 


PROCEDURE b; 
BEGIN IF i > O THEN 
BEGIN b(i-1); x t= x-h; y c= y-h; plot; 
c(i-1); y := y - 2*h; plot; 
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a(i-1); x t= x+h; y t= y-h; plot; 
b(i-1) 
END 
END ; 


PROCEDURE c; 
BEGIN IF i > O THEN 


BEGIN c(i-1); x c= x-h; y t= y+h; plot; 
d(i-1); x t= x = 2*h; plot; 
b{i-1); x t= x-h; y := y-h; plot; 
c{i-1) 
END 
END ; 
PROCEDURE d; 
BEGIN IF i > O THEN 
BEGIN d(i-1); x := x+h; y := y+h; plot; 
a(i-1); y := y + 2*h; plot; 
c(i-1); x := x-h; y t= y+h; plot; 
d(i-1) 
~ END 
END ; 


BEGIN startplot; 
ics 0; h t= hO DIV 4; xO t= 2*h; yO := 3*h; 
REPEAT i := i+1; xO z= xO-h; 
his h DIV 2; yO t= yOrh; 
x t= x0; y t= yO; setplot; 


a(i); x = x+h; y t= y-h; plot; 
b(i); x t= x-h; y t= y-h; plot; 
c(i); x t= x-h; y t= y+h; plot; 
d{i); x ts x+h; y t= y+h; plot 
UNTIL i = n; 
endplot 


END . 
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7. Sorting arrays 


Reference: N.Wirth, Algorithms + Data Structures = Programs, Prentice-Hall, Inc., 1975 


PROGRAM sort(output); 
CONST n = 256; nn = 512; 
TYPE index = O..nn; 
item = RECORD key: integer; 
(tother fields defined here*) 
END ; 


VAR i: index; r: integer; 
a: ARRAY [-15..nn] OF item; 
z: ARRAY [1..n] OF integer; 


PROCEDURE test(t: alfa; PROCEDURE sort); 
VAR i,z: integer; 

BEGIN write(" ", t); 
FOR i:= 1 TO n DO afij.key := i; ; 
z t= clock; sort; write(clock-z); 
FOR i:= 1 TO n DO afij-key := z{i]; ‘ 
z i= clock; sort; write(clock-z); 
FOR i := 1 TO n DO afi].key := n-i; 
z is clock; sort; writeln(clock-z); 

END (*test*) ; 


PROCEDURE straightinsertion; 
VAR i,j: index; x: item; 
BEGIN 
FOR i := 2 TO n DO 
BEGIN x := a[iJ; alO] := x; j := 
WHILE x.key < a[j].key DO 
BEGIN a{j+1] := alj]; j := i-1; 
END ; 


i-1; 


PROCEDURE binaryinsertion; 
VAR i,j,l,r,m: index; x:.item; 
BEGIN 
FOR i := 2 TO n DO 
BEGIN x := a{i]; [t= 1; r t= i-1; 
WHILE | <= r DO 
BEGIN m := (I+r) DIV 2; 
IF x.key < alm].key THEN r t= m-1 ELSE | := m+1; 
END ; 
FOR j := i-1 DOWNTO | DO afj+1] := aj]; 
a[l] := x; 
END 
END ; 


Sorting arrays 


PROCEDURE shellsort; 
CONST t = 
VAR i,j,.k,s: index; x: item; m: 1. 
h: ARRAY [1..t] OF integer; 
BEGIN h[1] := 9; h[2] z= 5; h[3] := 3; h[4] z= 
FOR mis 1 TO t DO 
BEGIN k := h[m]; s := -k; (*sentinel position’) 
FOR ji t+ k+1 TOn Be 
BEGIN x := ali]; j := i- 


IF s=O THEN s: we S$ := St+1; als] := x; 
WHILE x.key ¢ afj].key fae 
BEGIN a[j+k] := afj]; j c= j-k 
END ; 
aljt+k] 25) 
END 
END ; 
END ; 
PROCEDURE straightselection; 
VAR i,j,k: index; x: item; 
BEGIN FOR i := : TO n-1 DO 
BEGIN k := i; x t= ali]; 
FOR j := ist TO n DO 
IF a[j].key < x.key THEN 
BEGIN k := j; x := a{j] 
END ; 
a(k] := ati]; ali] := x; 
END 
END ; 
PROCEDURE heapsort; 
VAR Ir: index; x: item; 
PROCEDURE sift; 
LABEL 13; 
VAR i,j: index; 
BEGIN i t= [f; j t= 2°: x t= afi]; 


WHILE j <= r DO 
BEGIN IF j < r THEN 


IF a[j].key ¢ a[j+1].key THEN j := j+1; 


IF x.key >= ai]. ee THEN GOTO 13; 
ali] : = aliy; i a = 2*i 
END 
13: afi] := 
END ; 


BEGIN fits (n DIV 2) + 1; 7r: 
WHILE | > 1 DO 
BEGIN | := I-15 sift 
END ; 
WHILE r > 100 
BEGIN x := a{!]; afl] := afr]; afr] := 
ris r-1; silt 
END 
END (*heapsort*) ; 


r 
a 
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PROCEDURE bubblesort; 
VAR i,j: index; x: item; 
BEGIN FOR i := 2 TO n DO 
BEGIN FOR j := n DOWNTO i DO 
IF a[j-1].key > a[j].key THEN 
BEGIN x := a{j-1]; a{j-1] := afj]; afj] := x; 
END ; 
END 
END (‘*bubblesort*) ; 


PROCEDURE bubblex; 
VAR j,k,l index; x: item; 
BEGIN 1 := 2; 
REPEAT k := n; 
FOR j := n DOWNTO I DO 
IF a{j-1].key > alj].key THEN 
BEGIN x := a{j-1]; alj-1] := alj]; aff] := x; 
k ss j 
END ; 
Iss k+1 
UNTIL 1 > n 
END (*bubblex*) ; 


PROCEDURE shakersort; 
VAR j,k, r: index; x:item; 
BEGIN I := 2;rssen kiz nm 
REPEAT 
FOR j «= r DOWNTO I DO 
IF a{j-1].key > a[j].key THEN 
BEGIN x := a{ji-1]; afj-1] := afi]; afj]: 
k ts j 


il 
x 


FOR j:= | TO r DO 

IF afj-1].key > afj].key THEN 

BEGIN x := a[j-1]; a[j-1] := afj]; afi]: 
k ts j 


a 


x 


UNTIL 1 > r 
END (*shakersort*) ; 


Sorting arrays 


PROCEDURE quicksort; (*recursive*) 


PROCEDURE sort(I,r: index); 
VAR i,j: index; x,w: item; 
BEGIN ics fh jus on 
x i= a{(l+r) DIV 2]; 
REPEAT 
WHILE afi].key < x.key DO i c= j 
WHILE x.key < a[j].key DO j := j- 
IF i <= j THEN 
BEGIN w := afi]; ali] := aj]; alj] := w; 
ice itd; j ts jr 
END 
UNTIL i > j; 
IF | < j THEN sort(1,j); 
IF i < r THEN sort(i,r) 
END ; 


BEGIN sort(1,n) 
END (*quicksort*) ; 


PROCEDURE quicksort1; (*non-recursive’) 
CONST m = 12; 
VAR i,j,lr: index; 
x,w: item; 
s30.m; 
stack: ARRAY: [1..m] OF 
RECORD |r: index END ; 
BEGIN s := 1; stack[1].! := 1; stack[t]-r := n; 
REPEAT (*take lop request from stack*) 
) t= stack[s].l; r := stack[s].r s t= s-1; 
REPEAT (‘split a{l] ... afr]*) 
ice lj t= ry x c= ab(l+r) DIV 2]; 
REPEAT 


WHILE al[i].key < x.key DO i := i+1; 
WHILE x.key < alj]-key DO j := j-1; 
IF i <= j THEN 
BEGIN w := afiJ; afi] := a{j]; afi] := w; 
iss i441; fis j-t 

END 

UNTIL i > j; 

IF i < r THEN 

BEGIN (*stack request to sort right partition’) 
$ is S+1; stack[s].1 t= i; slack{s].r ts r 

END ; 

ris j 

UNTIL ! >= r 
UNTIL s = O 


END (*quicksortt*) ; 
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PROCEDURE mergesort; 
VAR iikit index; 
h,m,p,q,r: integer; up: boolean; 
(*nole that a has indices 1..2*n*) 
BEGIN up := true; p := 1; 
REPEAT h i= 1; m t= n; 


IF up THEN 

BEGIN ji :s 1; j t= nj k t= n+1; 1} ts 2*n 
END ELSE 

BEGIN k:= 1; fis miss nti; jis 2%n 
END ; 


REPEAT (*merge a run from i and j to k*) 
{*q = length of i-run, r = length of j-run*) 
lF m >= p THEN gq := p ELSE qi= m; mis m-q; 
IF m >= p THEN r:= p ELSE rcs m ms m-r; 
WHILE (q#0) AND (r#0) DO 
BEGIN (*merge’*) 
IF aLi].key < a[j].key THEN 
BEGIN ak] := aQij; k t= kth; i c= i+1) q c= q-1; 
END ELSE 
BEGIN afk] := a[j]; k t= kth; j t= j-d; t= 6-1; 
END 
END ; 
IF q = O THEN 
BEGIN (*copy tail of j-run*) 
WHILE r #0 DO 
BEGIN a[k] := a{j]; k t= kth; js jets rcs r-4; 
END 
END ELSE 
BEGIN (‘r = 0, copy tail of i-run*) 
WHILE q # 0 DO 
BEGIN afk] := afi]; k c= kth; i c= i#1; q t= q-1; 
END : 
END ; 
hss -hp tis kj kis ices t 
UNTIL m = 0; 
up := NOT up; p t= 2*p 
UNTIL p >= 7; 
IF NOT up THEN 
FOR i := 1 TO n DO afi] := aLi+n] 
END (*mergesort’) ; 


BEGIN i := 0; r := 54321; 

REPEAT i := i+1; 
r= (131071*r) MOD 2147483647; z[i] := r 

UNTIL i =.n; 
test("str insert", straightinsertion); 
test("bin insert”, binaryinsertion); 
test("“shell sort", shellsort); 
test("str select", straightselection); 
test("heapsort ", heapsort); 
test(“bubblesort", bubblesort); 
test(“bubblesort", bubblex); 
test(“shakersort", shakersort); | 
test("quicksort ", quicksort); 
test("quicksortt", quicksort1); 
test("mergesort ", mergesort); 

END . 
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8. Sequential sorting 
1. Natural merge sort with 3 files (tapes) and 2 phases. 


PROGRAM mergesort(input,output); 
TYPE item = RECORD key: integer 
(‘other fields defined here*) 
END ; 
tape = FILE OF item; 
VAR c: tape; n: buf: item; 


PROCEDURE list(VAR f: tape); 
VAR x: ilem; 
BEGIN reset(f); 
WHILE NOT eof(f) DO 
BEGIN read(f,x); write(output, x.key: 4) 
END ; 
writen 
END (*list*) ; 


PROCEDURE naturalmerge; 
VAR I: integer; (*no. of runs merged’) 
eor: boolean, (*end-of-run indicator’) 
a,b: tape; 


PROCEDURE copy(VAR x,y: tape); 

VAR buf: item; 
BEGIN read(x, buf); write(y,buf); 

IF eof(x) THEN eor := true ELSE eor := buf.key > xt.key 
END ; 


PROCEDURE copyrun(VAR x,y: tape); 

BEGIN (*copy one run from x to y*) 
REPEAT copy(x,y) UNTIL eor 

END ; 


PROCEDURE distribute; 
BEGIN (‘from c to a and b*) 
REPEAT copyrun(c,a); 
IF NOT eof(c) THEN copyrun(c,b) 
UNTIL eof(c) 
END ; 


PROCEDURE mergerun; 
BEGIN (*from a and b to c*) 
REPEAT 
IF at.key < bt.key. THEN 
BEGIN copy(a,c); 
IF eor THEN copyrun(b,c) 
END ELSE 
BEGIN copy(b,c); 
IF eor THEN copyrun(a,c) 
END 
UNTIL eor 
END ; 


PROCEDURE merge; 
BEGIN (*lrom a and b to c*) 
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REPEAT mergerun; | := [+1 
UNTIL eof(a) OR eof(b); 
WHILE NOT eof(a) DO 
BEGIN copyrun(a,c); 1 := +14 
END ; 
WHILE NOT eof(b) DO 
BEGIN copyrun(b,c); | := 141 
END ; 
list(c) 

END ; 


BEGIN 
REPEAT rewrite(a); rewrite(b); reset(c); 
distribute; 
resel(a); reset(b); rewrite(c); 
| := 0; merge; 
UNTIL J = 1 
END ; 


BEGIN (*main program. read input sequence ending with 0*) 
rewrite(c); read(buf.key); 
REPEAT write(c, buf); read(buf.key) 
UNTIL buf.key = 0; 
list(c); 
naturalmerge; 
list(c) 
END . 
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2. Sequential sorting by n-way mergesort. In each phase, data are merged from n/2 
files and distributed onto the other n/2 files. The program starls with the generation 
of a single file with random numbers. 


PROGRAM balancedmerge(oulput); 


CONST n = 6; nh = 3; (*no. of tapes*) 
TYPE item = RECORD 
key: integer 
END ; 


tape = FILE OF item; 
tapeno = 1..n; 

VAR leng, rand: integer; - (*used to generate file*) 
eot: boolean; 
buf: item; 
fO: tape; (*fO is the input tape with random numbers*) 
f: ARRAY [1..n] OF tape; 


PROCEDURE list(VAR f: tape; n: tapeno); 
VAR 2z: integer; 
BEGIN writeln(" tape", n:2); z := 0; 
WHILE NOT eof(f) DO 
BEGIN read(f, buf); write(output, buf.key: 5); z := z+1; 
IF z = 25 THEN 
BEGIN writeln(output); z := 0; 
END ; 
END ;: 
IF z # O THEN writeln(output); reset(F) 
END (*list*) ; 


PROCEDURE tapemergesort; 
VAR i,j,.mx,tx: tapeno; 

k1,k2,k integer; 

x, min: integer; 

t, ta: ARRAY [tapeno] OF tapeno; 

BEGIN (‘distribute initial runs to t[[1] ... t[nh]*) 
FOR i := V a nh DO rewrite(fLi}); 
jis nhj lt: 
REPEAT IF j me nh THEN j := j+1 ELSE j: 

(*copy one run from [0 to tape j*) 

[t= 1+; 

REPEAT read(fO, buf); write(f[jJ, buf) 

UNTIL (buf.key > fOt.key) OR eof(fO) 

UNTIL eof(fO); 
FOR i t= 1 TO n DO ti] c= i; 
REPEAT (*merge from t{1] .. t{nh] to t{nh+1] ... tin]*) 

IF i < nh THEN k1 := | ELSE k1 := nh; 

(*k1 = no. of input cece in this phase*) 

FOR i := 1 TO k1 
BEGIN esot(iLllrT}): ); Hist(ACtLiJ], t{F]); tali] := fi] 
END ; 

[:= 0; (*l = number of runs merged’) 

j t= nh+4; (*j = index of output tape*) 

REPEAT (*merge a run from t{1]... ((kiJ TO t{j]*) 
k2 i= k1; [t= l+#1; (*k2 = no. of active input tapes*) 
REPEAT (*select minimal element*) 

tts 1; mx is 1; min t= ([laf1]]t-key; 
WHILE i < k2 DO 
BEGIN i := i+1; x := f[tali]]t-key; 
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IF x < min THEN 
BEGIN min t= x; mx t= 
END 

END ; 

(*talmx] has minimal element, move it to t[j]*) 
toealltal mx 1 buf); eot := eof(fftafmx] ]); 
write(FFifj]], buf); 

IF eot THEN 
BEGIN rewrite(f[ta[mx]]); (‘eliminate tape*) 
ta[mx] := ta[k2]; tal[k2] := ta[k1]; 
kt := k1-1; k2 t= k2-1 
END ELSE 
IF buf.key > f{ta[mx]]t.key THEN 
BEGIN tx := ta[mx]; ta[mx] := ta[k2]; ta[k2] := bx; 
= k2-1 
END 
UNTIL k2 = 0; 
IF j < n THEN j := j+i ELSE j: ts nh+1 
UNTIL k1 = 0; 
FOR i := 1 TO nh DO 
BEGIN tx := t(iJ; tQij s= tlit+nh]; tLi+nh] := 
END 
UNTIL I = 1; 
reset(f[tl1]]); list((LIL1]]J, tL1]); (*sorted output is on t{1]*) 
END (*tapemergesort’) ; 


BEGIN (*generate random file fO*) 
leng := 200; rand := 7789; rewrite(fO); 
REPEAT rand := (131071’rand) MOD 2147483647; 
buf.key := rand DIV 2147484; write({0, buf); leng := leng - 1 
UNTIL feng = 0; 
reset(fO); tist(fO,1); 
tapemergesort; 
END . 
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3. Polyphase sort program. There are n-1 source files for merging and a single 
outpul file. The destination of the merged data changes, when a certain number of 
runs has been distributed. This number is computed according to a Fibonacci 
distribution. 


PROGRAM polysort(output); 


CONST n = 6; (*no. of tapes’) 
TYPE item = RECORD 
key: integer 
END ; 


tape = FILE OF item, 
tapeno = 1..n; 

VAR leng, rand: integer; (*used to generate file*) 
eot: boolean; 
buf: item; 
[O: tape; (*fO is the input tape with random numbers*) 
f. ARRAY [1..n] OF tape; 


PROCEDURE list(VAR f: tape; n: tapeno); 
VAR z: integer; 
BEGIN z := 0; 
writeln(" tape”, n:2); 
WHILE NOT eof(f) DO 
BEGIN read(f, buf); write(output, buf.key: 5); z t= z+} 


IF z = 25 THEN 
BEGIN writeln(output); z := 0 
END ; 
END ; 
IF z # O THEN writeln(output); reset(f) 
END (*list*) ; 


PROCEDURE polyphasesort; 
VAR i,j,mx,tn: tapeno; 

k, level: integer; 

a, d: ARRAY [tapeno] OF integer; 
(*af{j] = ideal number of runs on tape j’) 
(*d[j] = number of dummy runs on tape j*) 

dn, x, min, z: integer; 

last: ARRAY [tapeno] OF integer; 
(‘last{j] = key of tail item on tape j*) 

t,ta: ARRAY [tapeno] OF tapeno; 
(*mappings of tape numbers*) 


PROCEDURE selecttape; 
VAR i: tapeno; z: integer; 
BEGIN 
IF d{j] < d{j+1] THEN j := j+1 ELSE 
BEGIN IF d{j] = 0 THEN 
BEGIN level := level + 1; z := alt]; 
FOR i := 1 TO n-1 DO 
BEGIN df[i] := z + a{i+i] - afij; alij := z + afi+1] 
END 
END ; 
jis 
END ; 
d[jJ := d{j] -1 
ND ; 
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PROCEDURE copyrun; 

BEGIN (*copy one run from {0 to tape j*) 
REPEAT read({0, buf); write({{i], buf); 
UNTIL eof(fO) OR (buf.key > fOt.key); 
lasi{jJ := buf.key 

END ; 


BEGIN (*distribute initial runs*) 
FOR i:= 1 TO n-t DO : 
BEGIN ali] := 1; d[i] := 1; rewrite(f[i]) 
END ; 
level := 1; j := 1; afn] := 0; d[n] := 0; 
REPEAT selecttape; copyrun 
UNTIL eof(f0) OR (j=n-1); 
REPEAT selecttape; 
IF last{jJ <= fOt.key THEN 
BEGIN (*continue old run’) 
copyrun; 
IF eof({0) THEN d[j] := d[j] + 1 ELSE copyrun 
END 
ELSE copyrun 
UNTIL eof(fd); 
FOR i:= 1 TO n-1 DO reset(f[i]); 


FOR i t= 1 TO n DO tL] := i; 
REPEAT (*merge from t{1] ... t{n-1] to t{nJ*) 
z := a{n-1]; d[n] := 0; rewrite(f[t{n]]); 
writeiIn(" level", level:4, "tape", t{n]:4); 
FOR i := 1 TO n DO writein(tliJ, aliJ, d[iJ); 
REPEAT k := 0; (*merge one run*) 
FOR its 1 TO n-1 DO 
IF dliJ > O THEN dfi] :+ dfi]-1 ELSE 
BEGIN k := k+1; talk} := tli] 
END ; 
IF k = O THEN d[n] := d[n] + 1 ELSE 
BEGIN (*merge one real run from tlt]... t(k]*) 
REPEAT i := 1; mx t= 1; 
min := f{tal1]]t.key; 
WHILE i < k DO 
BEGIN i := i+1; x c= f{taliJ]t.key; 
IF x < min THEN 
BEGIN min := x; mx t= j 
END 
END ; 
(*tal[mx] contains minimal element, move it to t{n]*) 
read(f[ta[mx]], buf); eot := eof(f[taLmx]]); 
write({Ltln]], buf); 
IF (buf.key > f{talmx]]t.key) OR eot THEN 
BEGIN (“drop this tape*) 
ta[mx] := ta[k]; k t= k-1 
D 


reset(f{t(n]]); list((Etin]], t[n]); (‘rotate tapes*) 
In t= t{n];-dn t= dfn]; z := a{n-1]; 
FOR i := n DOWNTO 2 DO 
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d[i-1]; ali] := ai-1] - z 


BEGIN t{i] s= t{i-1]; d{i] : 
END ; 
(C1) s= tn; d[1] := dn; aft] := 2; 
(*sorted output is on t{1]*) 
level := level - 1 
UNTIL level = 0; 
END (*polyphasesort’*) ; 


BEGIN (*generate random file*) 
leng := 200; rand := 7789; 
REPEAT rand := (13107i*rand) MOD 2147483647; 
buf.key t= rand DIV 2147484; write(fO, buf); leng := leng - 1 
UNTIL leng = 0; 
reset(fO); list(f0,1); 
polyphasesort; 
D. 
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9. "Problem solving", backtracking. 


1. Find all setlings of 8 queens on an 8x8 chess board such that no queen checks 
another queen. [see also, Comm. ACM 14, 4, 221-27 (April 74)]. 


PROGRAM eightqueens(output); 
VAR i: integer; 
a: ARRAY [ 1..8 ] OF boolean; 
b : ARRAY [ 2..16] OF boolean; 
c : ARRAY [-7..7 ] OF boolean; 
x : ARRAY [ 1.8 ] OF integer; 
safe : boolean; 


PROCEDURE print; 
VAR k: integer; 

BEGIN write(" "); 
FOR k :s 1 TO 8 DO write(x[k]:2); 
writeln 

END ; 


PROCEDURE Irycol(j : integer); 
VAR i: integer; 


PROCEDURE setqueen; 
BEGIN ali] := false; b[i+j] := false; c[i-j] := false 
END ; 


PROCEDURE removequeen; 
BEGIN a[i] := true; b[i+j] := true; c[i-j] := true 
EMD ; 
BEGIN i := Q; 
REPEAT i := i+1; safe := ali] AND b{i+j] AND cfi-j]; 
IF safe THEN 
BEGIN setqueen; x[j] := i; 
IF | < 8 THEN trycol(j+1) ELSE print; 
removequeen 


END 
UNTIL i = 8 
END; 
BEGIN FOR i := 1 TO 8 DO afi := true; 
FOR ji ss 2 TO 16 DO bfi] := true; 
FOR i t= -7 TO 7 DO c[i] := true; 
irycol( 1); 


END. 
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2. Find sequences of digits 0, 1, 2 and of lengths 1... 90, such that they contain no 
two adjacent subsequences that are equal. 


PROGRAM sequenceO12(output); 
CONST maxlength = 90; 
VAR n: integer; 
good: boolean; 
s: ARRAY [1..maxlength] OF integer; 


PROCEDURE printsequence; 
VAR k: integer; 

BEGIN write(” "); 
FOR k z= 1 TO n DO write(s[k]:1); 
writeln 

END (*printsequence’) ; 


PROCEDURE changesequence; 
BEGIN IF s[n] = 3 THEN 
BEGIN n := n-1; changesequence 
END ELSE s[n] := succ(s[n]) 
END (*changesequence*) ; 


PROCEDURE try; 
VAR i,t,nhalf: integer; 
BEGIN IF n <= 1 THEN good := true ELSE 
BEGIN | := O; nhalf := n DIV 2; 
REPEAT tf := I+4; i := 0; 
(* compare tails of length | for equality *) 
REPEAT good := s[n-i] # s[n-I-i]; i c= i+1 
UNTIL good OR (i=l) 
UNTIL NOT good OR (l>=nhalf); 
END 
END (*try*); 


BEGIN n := 0; 
REPEAT n t= n+1; s[n] := 1; try; 
WHILE NOT good DO 
BEGIN changesequence; try 
END ; 
printsequence 
UNTIL n = maxlength 
END . 
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3. Find the smallest positive inleger that can be represented as the sum of to cubes 
(integers raised to the third power) in two different ways. 


PROGRAM sumofcubes(output); 
VAR i, ih, il, min, a, b, k: integer; 
j, sum, pwr: ARRAY [1..200] OF integer; 


(* pwr[k] = power of k, sum[k] = p[k] + pLilk]], 
j[k] = columnindex of last considered candidate in row k, 
ih = rowindex of highest considered row, 
il = rowindex of least still relevant row *) 
BEGIN i i= 1; il ts 1; ih t= 2; 
jL1] := 1; pwr[1] := 1; sum[ 1]: 
j[2] := 1; pwrL2] := 8; sum[2] : 
REPEAT 
min := sum[i]; a:= & b ¢= j[i; 
(* now get next sum in row i *) 
IF j[i] = i THEN 
BEGIN (* there is none felt *) il := ile; 
END ELSE 
BEGIN IF j[iJ = 1 THEN 
BEGIN (* the new min was from the first column, now add 
a new row before taking the new sum from the old row *) 
ih zs ih + 1; pwr[ih] t= ihtihtih; 
jin] := 1; sum[ih] := pwr[ih]+1; 
D . 


2; 
9; 
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END ; 
jCi] «= ifiJ+1; (* next candidate in row i *) 
sum[i] := pwrfi] + pwr[jli}] 
END ; 
(* now find minimal candidate in rows il .. ih *) 
iis ih k rs i+; 
WHILE k <= ih DO 
BEGIN IF sum[k] < sum[i] THEN i :s= k} ko i= k+1 
END , 
UNTIL. sum[i] = min; 
writeln(min,a,b,i,i£i}) 
END . 
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4. Find a path of a knight on a chess board which covers all 64 squares. 


PROGRAM knightstour(outpul); 
CONST n = 5; nsq = 25; 
TYPE index = 1..n; 
VAR i,j: index; 
q: boolean; 
s: SET OF index; 
a,b: ARRAY [1..8] OF integer; 
h: ARRAY [index, index] OF integer; 


PROCEDURE try(i: integer; x,y: index; VAR q: boolean); 
VAR k,u,v: integer; qi: boolean; 
BEGIN k := 0; 
REPEAT k := k+1; qt := false; 
uUi= xX + alk]; vis y + b[k]; 
IF (u IN s) AND (v IN s) THEN 
IF h{u,v] = 0 THEN 
BEGIN h[u,v] := § 
IF i < nsq THEN 
BEGIN try(i+1,u,v,q1); 
IF NOT qt THEN h[u,v] := 0 
END ELSE q1 := true 
END 
UNTIL qt OR (Ik=8); 


qi= qi 
END (‘ttry*) ; 


BEGIN gs :s (1,2,3,4,5]; 
atl} c= 2; bf1] c= 1; 
al2] := 1; bL2]:= 2; 
aL3] = -1; bf£3] s+ 2; 
af4] ss -2; b[4] += 1; 
al5] := -2; b[5] := -1; 
al6] :=+ -1; bL6] := -2; 
al7]:= 1; b[7] := -2; 
al8] t= 2; bE 8] t= -1; 


FOR j := 1 TO n DO bfi,j} := 0; 
hL1,1J z= 4; try(2,1,1,q); 
IF q THEN 
FOR i zs 1 TOnDO 
BEGIN FOR j := 1 TO n DO write(h[i,j]:5); 
writeln 
END 
ELSE writeln(" no solution ") 
END. 


At 
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5. Find a solution to the stable marriage problem. nm men and n women stale their 
preferences of partners, Find n pairs such that no man would prefer to be married to 
another woman who would also prefer him to her partner. A set of pairs is called 
stable, if no such cases exist [see also Comm. ACM 14, 7, 486-92 (July 71)]. 


PROGRAM marriage(input,output); 
CONST n = 8; 
TYPE man = 1..n; woman = 1..n; rank = 1..n; 
VAR m: man; w: woman; r: rank; 
wmr: ARRAY [man, rank] OF woman; 
mwr: ARRAY [woman, rank] OF man; 
rmw: ARRAY [man, woman] OF rank; 
rwm: ARRAY [woman, man] OF rank; 
x: ARRAY [man] OF woman; 
y: ARRAY [woman] OF man; 
single: ARRAY [woman] OF boolean; 


PROCEDURE print; 
VAR m: man; rm, rw: integer; 
BEGIN rra := 0; rw t= 0; 
FOR m:=z 1 TO nDO 
BEGIN write(x[m 1:4); 
rm c= rm + rmwlm,x[m]J; rw cs rw + rwm[x{m],m]j 
END ; 
writein(rm:8,rw:4); 
END (*print*) ; 


PROCEDURE try(m: man); 
VAR r: rank; w: woman; 


FUNCTION stable: boolean; 
VAR pm: man; pw: woman; 
i, lim: rank; s: boolean; 
BEGIN s := true; i:= 1; 
WHILE (i<r) AND s DO 


BEGIN pw := wmrlm,ij; i := i+4; 
IF NOT single[pw] THEN s := rwm[Epw,m] > rwm[pw,y[pw]] 
END ; 


its 1; lim t= rwm[w,m]; 
WHILE (i<lim) AND s DO 


BEGIN pm := mwr[w,i]; i ts i44; 

IF pm < m THEN s := rmw[pm,w] > rmw[pm,x[pm]J] 
END ; 
slable t= § 


END (*test*) ; 


BEGIN (*try*) 
FOR r:= 1TOnDO 
BEGIN w := wmr[m,r]; 
IF single[w] THEN 
IF stable THEN 
BEGIN x[m] := w; y[w] := m; single[w] := false; 
IF m <n THEN try(suce(m)) ELSE print; 
single[w] := true 
END 
END 
END (‘try*) ; 
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BEGIN writeln("1"); 
FOR mis 1 TOnDO 
FOR ris 1 TO n DO 
BEGIN read(wmr[m,rJ); rmwE£m,wmr[m,r]] = 
END ; 
FOR w t= 1 TO n DO 
FOR ris 1 TO nDO 
BEGIN read(mwrf{w,r]); rwmELw,mwrLwyr]] : 
END ; 
FOR w := 1 TO n DO single[w] := true; 
try(1) 
END. 
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6. Find an optimal selection of objects from a given set of n objects under a given 
constraint. Each object is characterised by two properties v (for value) and w (for 
weight). The optimal selection is the one with the largest sum of values of ils 
members. The constraint is that the sum of their weights must nol surpass a given 
limit fimv. The algorithm is called branch and bound. 


PROGRAM selection(input,output); 
CONST n = 10; 
TYPE index = 1..n; 

object = RECORD v,w: integer END ; 
VAR i: index; 

a: ARRAY [index] OF object; 

limw, totv, maxv: integer; 

wi, w2, w3: integer; 

s, opts: SET OF index; 

z: ARRAY [boolean] OF char; 


PROCEDURE try(i: index; tw,av: integer); 
VAR avi: integer; 
BEGIN (‘try inclusion of object i*) 
IF tw + afi].w <= limw THEN 
BEGIN sis s + [i]; 
IF i <n THEN try(i+1, tw+ali].w, av) ELSE 
IF av > maxv THEN 
BEGIN maxv := av; opts t= $ 
END ; 
sie s- [i] 
END ; 
(*now try without object i*) avi t= av - aliy.v; 
IF avt > maxv THEN 
BEGIN IF i < n THEN try(i+1, tw, avt) ELSE 
BEGIN maxv := avi; opts := s 
END 
END 
END (*try*) ; 


BEGIN totv := 0; 

FOR i i= 1 TOn DO 
WITH afi] DO 
BEGIN read(w,v); tolv := totv + v 
END ; 

read(w1,w2,wa); 

z[true] i= "*"; z[false] c=" "5 

wrilte(" weight "); 

FOR i t= 1 TO n DO write(a[iJ.w:4); 


writeln; write(" value eye 
FOR i ‘t= 1 TO n DO write(ali].v:4); 
writeln; 


REPEAT limw ‘= wi; maxv := 0; s := []; opts := [1]; 
try( 1,0, totv); 
write(limw); ; 
FOR i:= 1 TO n DO write("—", zi IN opts]); 
writein; wi c= wi + w2 ° 
UNTIL wt > w3 
END . 


45 


List and tree structures, pointers 


10. List and tree structures, pointers. 


1. A procedure search is to locate records with a given key in an ordered list. {ff the 
key is not present, then a new record is to be inserted so that the ordering of keys is 


maintained. Use a sentinel at the end of the list. 


PROGRAM list(input,output); 
TYPE ref = tword; 
word = RECORD key: integer; 
count: integer; 
next: ref 
END ; 
VAR k: integer; root, sentinel: ref; 


PROCEDURE search(x: integer; VAR root: ref); 
VAR wt,w2,wa: ref; 
BEGIN w2 := root: wi := w2t.next, sentinelt.key := x; 
WHILE wit.key < x DO 
BEGIN w2 := wi; wi t= w2t.next 


END ; 
IF (wit.key = x) AND (w1 # sentinel) THEN 


wit.count := wtt.count + 1 ELSE 
BEGIN new(w3); (tinsert w3 belween w1 AND we2*) 


WITH w3t DO 


BEGIN key := x; count := 1; next := wi 
END ; 
w2t.next := w3 
END 


END (*search*) ; 


PROCEDURE printlist(w,z: ref); 
BEGIN WHILE w # z DO 
BEGIN writein(wt.key, wt.count); 
Ww i= Wt.next 
END 
END (*printlist*) ; 


BEGIN new(root); new(sentinel); rooltt.next := sentinel; 


read(k); 
WHILE k # 0 DO 
BEGIN search(k, root); read(k) 
END ; 
printlist(roott.next,sentinel) 


END. 
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2. Instead of keeping the list ordered according to keys, reorder it as follows: After 
each search, the accessed record is moved to the top of the list. In this case, 
repeated accesses to the same element will be very fast. Use a sentinel at the end 
of the list. 


PROGRAM lisi{input,oulput); 
TYPE ref = tword; 
word = RECORD key: integer; 
count: integer; 
next: ref 
END ; 
VAR k: integer; root, sentinel: ref; 


PROCEDURE search(x: integer; VAR root: ref); 
VAR wi,we: ref; 
BEGIN w1 := rool; sentinelt.key t= x; 
IF wi = sentinel THEN 
BEGIN (‘first element*) new(root); 
WITH roott DO 
BEGIN key := x; Count := 1; next := sentinel 
END 
END ELSE 
IF wit.key = x THEN wit.count :=s wit.count + 1 ELSE 
BEGIN (*search*) 
REPEAT w2 := wi; wi t= w2t.next 
UNTIL wit.key = x; 
IF wi = sentinel THEN 
BEGIN (‘insert*) 
w2 := rool; new(root); 
WITH roott DO 
BEGIN key := x; count := 1; next := w2 
END 
END ELSE 
BEGIN (*found, now reorder’) 
wit.count := wit.count + 1; 
w2t.next := wilt.next; wit.next t= root; root := wt 
END 
END 
END (*search’) ; 


PROCEDURE prinllist(w,z: ref); 
BEGIN WHILE w # z DO 
BEGIN writeln(wt.key, wt.count); 
W i= wt.next 
END 
END (*printlist*) ; 


BEGIN new(sentinel); root := sentinel: 
read(k); 
WHILE k # 0 DO 
BEGIN search(k, root); read(k) 
END ; 
printlist(root,sentinel) 
END . 


List and tree structures, pointers 47 


3. Read a sequence of relations defining a directed, finite graph. Then establish 
whether or not a partial ordering is defined. !f so, print the elements in a sequence 
showing the partial ordering. (Topological sorting). 


PROGRAM topsort{input,oulput); 
TYPE Iref = tleader; 
tref = ttrailer; 
leader = RECORD key: integer; 
count: integer; 
trail: tref; 


next: Iref; 
END ; 
trailers RECORD id: Iref; 
next: tref 
END ; 


VAR head, tail, p,q: Iref; 
i: tref; z: integer; 
%y: integer; 


FUNCTION [{w: integer): Iref; 
(‘reference to leader with key w*) 
VAR hi: Iref; 
BEGIN h := head; taiit.key := w; (*sentinel*) 
WHILE ht.key # w DO hice ht.next; 
IF h = tail THEN 
BEGIN (‘no element with key w in the list’) 
new(tail); z := Z+1; 
ht.count := O; ht.trail := NIL; ht.next := tail 
END ; 
lis h 
END (*1*) ; 


BEGIN (‘initialise list of leaders with a dummy*) 
new(head); tail = head; z := 0; 


(tinput phase*) read(x); 

WHILE x # 0 DO 

BEGIN read(y); writeln(x,y); 
p t= W(x); q c= My); 
new(t); tt.id := q; tt.next := pt.trail; 
pt.trail := t} qt.count := qt.count + 1; 
read(x) 

END ; 


(‘search for leaders with count = 0*) 

p is head; head := NIL; 

WHILE p # tail DO 

BEGIN q:= p; p c= pt.next; 

IF qt.count = 0 THEN 

BEGIN qt.next := head; head ‘= q 
END ; 

END ; 


(‘output phase") q := head; 
WHILE q # NIL DO 
BEGIN writeln(qt.key); Zz t= z-1; 
tis qt-trail;'q t= qt.next; 
WHILE t # NIL DO 
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BEGIN p := tt.id; pt.count := pt.count - 1; 
IF pt.count = 0 THEN 
BEGIN (‘insert pt in q-list*) 

pt.next := q; q i= p 


END ; 
t t= tt.next 
END 
END ; 


IF z # O THEN writeln(" this set is not partially ordered") 
END . 
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4. \Inserlion and deletion in a binary tree. Read a sequence of integers. A positive 
integer signifies that it should be inserted in an ordered binary tree as the key of a 
node. A negative integer signifies that a node with its absolule value as key should 
be searched and deleted. 


PROGRAM tree(input, output); 
TYPE ref = tword; 
word = RECORD key: integer; 
count: integer; 
left, right: ref; 
END ; 
VAR root: ref; k: integer; 


PROCEDURE printtree(w: ref; I: integer); 
VAR i: integer; 
BEGIN IF w # NIL THEN 
WITH wt DO 
BEGIN printtree(left, [4+1); 
FOR i z= 1 TODO write(" "); 
writeln(key); 
printtree(right, 1+1) 
END 
END ; 


PROCEDURE search(x: integer; VAR p: ref); 
BEGIN 
IF p = NIL THEN 
BEGIN (‘word is not in tree; insert it*) 
new(p); 
WITH pt DO 
BEGIN key := x; count :+ 1; left := NIL; right := NIL 
END 
END ELSE 
IF x < pt.key THEN search(x, pt.left) ELSE 
IF x > pt.key THEN search(x, pt.right) ELSE 
pt.count := pt.count + 1 
END (*search*) ; 


PROCEDURE delete(x: integer; VAR p: ref); 
VAR q: rel; 


PROCEDURE del(VAR r: ref); 

BEGIN IF rt.right # NIL THEN del(rt.right) ELSE 

BEGIN qt.key := rt.key; qt.count := rt.count; 
qis rj rts rt.left 

END 

END ; 


BEGIN (*delete*) 
IF p = NIL THEN writein(" word is not in tree") ELSE 
iF x < pt.key THEN delete(x, pt.left) ELSE 
IF x > pt.key THEN delete(x, pt-right) ELSE 
BEGIN (‘delete pt') q:= Pp; 
IF qt.right = NIL THEN p := qtJeft ELSE 
IF qtJeft = NIL THEN p := qt.right ELSE del(qt.left); 
(*dispose(q)*) 
END 
END (‘delete’) ; 


50 Pascal programs 


BEGIN root := NIL; read(k); 
WHILE k # 0 DO 
BEGIN IF k > O THEN 
BEGIN writeln(" insert", k); search(k,root) 
END ELSE 
BEGIN wrifeln(" delete",-k); delete({-k,root) 
END ; 
printtree(root,O); read(k) 
END ; 
END , 
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5. Insertion and deletion in a AVL-balanced tree. In the previous program, the binary 
tree may grow in all sorts of shapes -- if the inserted keys are ordered upon arrival, 
the “tree” even degenerales into a linear list. In the following program, a balance is 
maintained, such that at each node the heights of its two subtrees differ by at most 1. 


PROGRAM baltree(input,output); 
TYPE ref = tword; 
word = RECORD key: integer; 
count: integer; 
left, right: ref; 
bal: -1..4+1 
END ; 
VAR root: ref; h: boolean; k: integer; 


PROCEDURE printtree(w: ref; I: integer); 
VAR i: integer; 
BEGIN IF w # NIL THEN 
WITH wt DO 
BEGIN printlree(left, 1+1); 
FOR i:= 1 TO? DO write("—"); 
writeln(key:5, bal:3); 
printtree(right, 1+1) 
END 
END ; 


PROCEDURE search(x: integer; VAR p: ref; VAR h: boolean); 
VAR pi,p2: ref; (*h = false*) 
BEGIN 
IF p = NIL THEN 
BEGIN (*word is not in tree; insert it’) 
new(p); h t= true; 
WITH pt DO 
BEGIN key t= x; count ‘= 1; 
left s= NIL; right := NIL; bal := 0 
END 
END ELSE 
IF x < pt.key THEN 
BEGIN search(x, pt.left, h); 
IF h THEN (“left branch has grown higher’) 
CASE pt.bal cas 


1: BEGIN pt.bal : := false 
END ; 
0: pt.bal tao 


-1: BEGIN (trebalance*) p1 := pt.left; 

IF pit.bal = -1 THEN 

BEGIN (*single LL rotation’) 
pt.left := pit. right; pit.right := p; 
pt.bal := 0; p t= pl 

END ELSE 

BEGIN (*double LR rotation*) p2 := ptt-.righl; 
pit.right := p2t.lefl; p2tleft := pt; 
ptJeft := p2t.right; p2t.right := p; 
IF p2t.bal = -1 THEN pt.bal := +1 ELSE pt.bal := 0; 
IF p2t.bal = +1 THEN pit.bal := -1 ELSE p1t.bal := 0; 
p i= pe 

END ; 

pt.bal := 0; h c= false 

END 


52 Pascal programs 


END. 
END ELSE 
IF x > pt.key THEN 
BEGIN search(x, pt.right, h); 
IF h THEN (‘right branch has grown higher*) 
CASE pt.bal OF 
-1: BEGIN pt.bal := 0; h := false 
END ; 
0: pt.bal := +1; 
1: BEGIN (‘rebalance’) pi := pt.right; 
IF pit.bal = +1 THEN 
BEGIN (‘single RR rotation*) 
pt.right := pit left; pit.left := p; 
pt.bal := 0; p t= pi 
END ELSE 
BEGIN (*double RL rotation*) p2 := pit.left; 
pitdeft := p2t.right; p2t.right := p1; 
pt.right := p2t.left; p2tdeft := p; 


IF p2t.bal = +1 THEN pt.bal := -1 ELSE pt.bal := ee 
IF p2t.bal = -1 THEN pit.bal := +1 ELSE p1t.bal := 
p i= pe 
END ; 
pt.bal := 0; h := false 
END 
END 
END 
ELSE 
BEGIN pt.count := pt.count + 1; h := false 
END 


END (‘search’) ; 


PROCEDURE delete(x: integer; VAR p: ref; VAR h: boolean); 
VAR q: ref; (*h = false’) 


PROCEDURE balance1(VAR p: ref; VAR h: boolean); 
VAR pt,p2: ref; b1,b2: -1..41; 

BEGIN (*h = true, left branch has become less high’) 
CASE pt.bal OF 


-1: pt.bal := 0; 
0: BEGIN pt.bal := +1; h:= false 
END ; 


1: BEGIN (*rebalance*) p1 := pt.right; b1 := p1t.bal: 

IF bt >= 0 THEN 

BEGIN (‘single RR rotation’) 
pt.right := pit.left; ptt.left := p; 
IF b1 = O THEN 
BEGIN pt.bal := +1; p1t.bal := -1; h := false 
END ELSE 
BEGIN pt-.bal := 0; ptt.bal := 0 
END ; 
p t= pt 

END ELSE 

BEGIN (*double RL rotation’) 
p2 := pit.left; b2 := p2t.bal; 
pit.leit := p2t. rights p2t.right := p14; 
pt.right := p2tlelt; p2t.left := p; 
IF b2 = +1 THEN pt.bal := -1 ELSE pt.bal := 0; 
IF b2 = -? THEN pit.bal := +1 ELSE pit.bal := 0; 
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p i= p2; p2t.bal := 0 
END 
END 
END 
END (*balance1*) ; 


PROCEDURE balance2(VAR p: ref; VAR h: boolean); 
VAR p1,p2: ref; b1,b2: -1..+1; 
BEGIN (*h = true, right branch has become less high*) 
CASE ene OF 
1: pt.bal : 
0: BEGIN pt. ae sh a falee 
END ; 
~1: BEGIN (*rebalance*) pt := pt.left; "bt: = pit.bal; 
IF bi <= O THEN 
BEGIN (*single LL rotation’) 
pt.left := pit.right; p1t.right := 
IF b1 = 0 THEN 
BEGIN pt.bal := -1; pit.bal := +1; h := false 
END ELSE 
BEGIN pt.bal := 0; ptt.bal := 
END ; 
pi=pt 
END ELSE 
BEGIN (*double LR rotation”) 
p2 c= pit.right; b2 := p2t.bal; 
PE eTIBn ss p2t. left; “p2t.left = 
pt.left := p2t.right; p2t.right := a 
IF b2 = -1 THEN pt.bal := +1 ELSE pt.bal := 
IF b2 = +1 THEN pit.bal := -1 ELSE pit.bal := 
p i= p2; p2t.bal := 0 
END 
END 
END 
END (*balance2*) ; 


PROCEDURE del(VAR r: ref; VAR h: boolean); 
BEGIN (*h = false*) 
IF rt.right # NIL THEN 
BEGIN del(rt.right,h); IF bh THEN balance2(r,h) 
END ELSE 
BEGIN qt.key := rt.key; qt.count := rt.count; 
ris rt.left; h := true 
END 
END ; 


BEGIN (‘delete’) 

IF p = NIL THEN 
BEGIN writeln(" key is not in tree"); h := false 
END ELSE 

IF x ¢ pt.key THEN 
BEGIN delete(x,pt.teft,h); IF h THEN balance 1(p,h) 
END ELSE 

IF x > pt.key THEN 
BEGIN delete(x,pt.right,h); IF h THEN balance2(p,h) 
END ELSE 

BEGIN (‘delete pt*) q ‘= Dp; 
IF qt.right = NIL THEN 
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BEGIN p := qt.Jeft; h :s true 
END ELSE 

IF qt.left = NIL THEN 
BEGIN p c= qt-right; h c= true 
END ELSE 

BEGIN del(qt.lefth); : 
IF fh THEN balance1(p,h) 

END ; 

(*dispose(q)*) 

END 


END (*delete*) ; 


BEGIN read(k); root := NIL; 
WHILE k # 0 DO 
BEGIN IF k >= 0 THEN 
BEGIN writein(" insert", k); search( k,root,h) 
END ELSE . 
BEGIN writeln(" delete",-k); delete(-k,root,h) 
END ; 
printtree(root,O); read(k) 
END ; 
END. 
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6. Insert and delete elements in a B-tree of page size 2n. Read a sequence of keys; 


positive values denote insertion, negative ones deletion. Print the resulting B-tree 
alter each operation. 


PROGRAM Btree(input,output); 
CONST n = 2; nn = 4; (*page size’) 
TYPE ref = tpage; 

item = RECORD key: integer; 


p: ref; 
count: integer; 
END ; 
page = RECORD m: O..nn; (*no. of items*) 
po: ref; 
e: ARRAY [1..nn] OF item; 
END ; 


VAR root, q: ref; x: integer; 
h: boolean; u: item; 


PROCEDURE printtree(p: ref; I: integer); 


VAR i: integer; 
BEGIN IF p # NIL THEN 
WITH pt DO 
BEGIN FOR i:= 1 TO 1 DO write("—*); 
FOR i := 1 TO m DO write(e[i].key: 4); 
writeln; 


printtree(p0,l+1); 
FOR i := 1 TO m DO printtree(eLi].p, 1+1) 
END 
END ; 


PROCEDURE search(x: integer; a:ref; 

VAR h: boolean; VAR v: item); 
(*search key x on B-tree with root a; if found, increment counter. Otherwise 
insert an item with key x and count 1 in tree. If an item emerges to be passed 
to a lower level, then assign it to v; h:= "tree a has become higher"*) 


VAR k,hr: integer; q: ref; u: item; 
PROCEDURE insert; 


VAR i: integer; b: ref; 
BEGIN (‘insert u to the right of at.e{r]*) 


WITH at DO 
BEGIN IF m ¢< nn THEN 
BEGIN m := m+1; h t= false; 
FOR i := m DOWNTO r+2 DO e[i] := efi-1]; 
e[r+1] := u 
END ELSE 


BEGIN (‘page at is full; split it and assign the emerging 
item to v*) new(b); 
iF r <= n THEN 
BEGIN IF r = n THEN v := u ELSE 
BEGIN v := e[n]; 
FOR i := n DOWNTO r+2 DO e[i] := e[i-1]; 
e[r+1] i= u 
END ; 
FOR i := 1 TO n DO bt.efi] <= at-e[i+tn]; 
END ELSE 
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BEGIN (‘insert u in right page*) r c= r-nj v t= e[n+1]; 
FOR i:s 1 TO r-1 DO bt.e[i] := at.e[i+n+1]; 


bt.e[r] := u; 
FOR i :=s r+1 TO n DO bt.efi] := at.e[i+n] 
END ; 
m i= n; bt.m := n; bt.pO := v.p; v.p := b; 
END 


END (*WITH*) 
END (*insert*) ; 


BEGIN (‘search key x on page at; h = false*) 
IF a = Nil THEN 
BEGIN (‘item with key x is not in tree*) h := true; 
WITH v DO 
BEGIN key := x; count := 1; p := NIL 
END 
END ELSE 
WITH at DO 
BEGIN ft := 1; ¢:= m; (‘binary array search’) 
REPEAT k := (l4r) DIV 2; 
IF x <= e[k]-key THEN r c= k-1; 
IF x >= e[k].key THEN | := k+1; 
UNTIL r ¢ 1; 
IF i-r > 4 THEN 
BEGIN (*found*) e[k].count := e[k].count + 1; h := false 
END ELSE 
BEGIN (‘ilem is not on this page*) 
IF r = O THEN q := pO ELSE q := e[r].p; 
search(x,q,h,u); IF h THEN insert 
END 
END 
END (‘search’) ; 


PROCEDURE delete(x: integer; a: ref; VAR h: boolean); 


("search and delete key x in B-tree a; if a page underflow is necessary, 
balance with adjacent page if possible, otherwise merge; h := "page a.is 


undersize"*) 
VAR ik,l,r: integer; q: ref; 


PROCEDURE underflow(c,a: ref; s: integer; VAR h: boolean); 
(*a = underflow page, c = ancestor page*) 
VAR b: ref; iksmb,me: integer; 
BEGIN mc := ct.m; (*h = true, at.m = n-1%) 
IF s ¢ mc THEN 
BEGIN (*b := page to the ‘right of at) s t= s+1; 
b := ct.e[s].p: mb := bt.m; k :s (mb-n+1) DIV 2; 
(*k = no. of items available on adjacent page b*) 
at.e[n] := ct.e[s]; at.e[n].p := bt.p0; 
IF k > 0 THEN 
BEGIN (*move k items from b to a*) 
FOR i:s 1 TO k-1 DO at.e[i+n] := bt-e[i]; 
ct.e[s] := bt.e{k]; ct.e[s].p := b; 
bt.p0 := bt.e[k].p; mb := mb-k; 
FOR i := 1 TO mb DO bt.e[i] := bt.eLi+k]; 
bt.m := mb; at.m := n-t+k; h :s false 
END ELSE 
BEGIN (*merge pages a and b*) 
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FOR i:= 1 TO n OO at.e[i+n] := bt.e[i]; 


FOR i:= s TO mc-1 DO ct.eLi] := ct.eLi+1]; 
at.m ts nn; Ct.m := mc-1; (*dispose(b)*) 
END 
END ELSE 
BEGIN (*b := page to the left of a’) 
IF s = 1 THEN b := ct.p0 ELSE b := ct.e[s-1].p; 
mb := bt.m + 1; k := (mb-n) DIV 2; 


IF k > O THEN 
BEGIN (*move k items from page b to a*) 
FOR i t= n-1 DOWNTO 1 DO at.e[i+k] := at.eLi]; 


at.e[k] :+ ct.e[s]; at.e[k].p := at.p0; mb := mb-k; 
FOR i := k-1 DOWNTO 1 DO at.e[i] := bt.eLi+mb]; 
at.pO := bt.e[mh].p; 


ct.eLs] := bt.e[mb]; ct.e[s].p := a; 
bt.m is mb-1; at.m t= n-1i+k; h c= false 

END ELSE . 

BEGIN (*merge pages a and b*) 
bt.e[mb] :=+ ct.e[s]; bt.e[mb].p := at.po; 
FOR i c= 1 TO n-1 DO bt.e[it+mb] := at.eLi]; 
bt.m ‘= nn; ct.m := mc-1; (*dispose(a)*) 

END 
END 

END (tunderflow*) ; 


PROCEDURE del(p: ref; VAR h: boolean); 
VAR q: ref; (*global a,kk*) 
BEGIN 
WITH pt DO 
BEGIN q := e[m].p; 
IF q # NIL THEN 
BEGIN del{q,h); IF h THEN underflow(p,q,m,h} 
END ELSE 
BEGIN pt.e[m].p :+ at.e[k].p; at.e[k] := pt.e[m]; 
mis m-1; hes mén 
END 
END 
END (*del*) ; 


BEGIN (‘delete’) 
IF a = NIL THEN 
BEGIN writeln(" key is not in tree"); h := false 
END ELSE 
WITH at DO 
BEGIN | := 1; rcs m; (*binary array search*) 
REPEAT k := (l4+r) DIV 2; 
IF x <= e[k].key THEN r c= k-1; 
IF x >= e[k].cey THEN I c= k+1; 
UNTIL 1 > 6; 
IF r=0 THEN q := pO ELSE q:s= e[r].p; 
IF l-r > 1 THEN 
BEGIN (*found, now delete e[k]*) 
IF q = NIL THEN 
BEGIN (‘a is a terminal page*) m t= m-1; h c= m<n; 
FOR i:= k TO m DO efi] t= e[i+t]; 
END ELSE 
BEGIN del(q,h); IF h THEN underflow(a,q,r,h) 
END 
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END ELSE 
BEGIN delete(x,q,h); IF h THEN underflow(a,q,r.h) 
END 
END 
END (‘delete*) ; 


BEGIN root := NIL; read(x); 
WHILE x # 0 DO 
BEGIN writeiIn(" search key", x); 
search(x,roat,h,u); 
IF h THEN 
BEGIN (*insert new base page’) q := root; new(rool); 
WITH roott DO 
BEGIN m := 1; pO := q; ef 1] t= u 
END 
END ; 
printtree(root,1); read(x) 
END ; 
read(x); 
WHILE x # 0 DO 
BEGIN writeln(" delete key", x); 
delete(x,rool,h); 
IF h THEN 
BEGIN (*base page size was reduced’) 
IF roott.m = 0 THEN . 
BEGIN q := root; root := qt.p0; (*dispose(q)*) 
END ; 
END ; 
printiree(root,1); read(x) 
END 
END . 
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7. Find the optimally structured binary search tree for n keys. Known are the search 
frequencies of the keys, b[i] for key[i]J, and the frequencies of searches with 
arguments that are not keys (represented in the tree). afi] is the frequency of an 
argument fying between key[i-1] and key[i]. Use Knuth's algorithm, Acta Informatica 
1, 1, 14-25 (1971). The following example uses Pascal keywords as keys. 


PROGRAM optimaltree(input,output); 
CONST n = 31; (*no. of keys*) 
kin = 10; (*max keylength*) 
TYPE index = 0..n; 
alfa = PACKED ARRAY [1..kIn] OF char; 
VAR ch: char; ? 
k1, k2: integer; 
id: alfa; (‘identifier or key*) 
buf: ARRAY [1..kIn}] OF char; = (*character buffer") 
key: ARRAY [1..n] OF alfa; 
ijk: integer; 
a: ARRAY [1..n] OF integer; 
b: ARRAY [index] OF integer; 
p,w: ARRAY [index,index] OF integer; 
r: ARRAY [index,index] OF index; 
suma, stuumb: integer; 


FUNCTION baltree(i,j: index): integer; 
VAR k: integer; 
BEGIN k := (i+j+1) DIV 2; r[i,j] c= k; 
IF i >= j THEN baltree := b[k] ELSE 
baltree := baltree(i,k-1) + baltree(k,j) + wLi,j] 
END (*baltree*) ; 


PROCEDURE opttree; 
VAR x, min: integer; 
iik,h,m: index; 
BEGIN (*argument: w, result: p,r*) 
FOR i:= 0 TOn DO pfi,i] := wfi,ij; (*width of tree h = 0*) 


FOR i := 0 TO n-1 DO (*width of tree h = 1* 
BEGIN j := i+1; 
PLidJ := elit] + pCi): lid ss ij 
END ; 
FOR h:= 2 TOn DO (* h = width of considered tree *) 
FOR i t= 0 TO n-h DO (* i = left index of considered tree *) 


is: 
BEGIN j := ith; (* j = right index of considered tree *) 
mots r[ije1]J; min := pLim-1] + plm,j]; 
FOR k := m+1 TO r[i+1,j] DO 
BEGIN x := pLik-1] + pli]; 
IF x < min THEN , 
BEGIN m := k; min := x 


END 
END ; 
pLij] := min + wij; Lig] c= m 
END ; 


END (*opttree*) ; 


PROCEDURE printtree; 
CONST Iw = 120; (‘line width of prinler*) 
TYPE ref = tnode; 
lineposilion = 0..Iw; 
node = RECORD key: alfa; 
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pos: lineposition; 
left, right, link: ref 
END ; 
VAR root, current, next: ref; 
q.q1,q2: ref; 
i: integer; 
k: integer; 
u, u1, u2, u3, ud: lineposition; 


FUNCTION tree(i,j: index): ref; 
VAR p: ref; 
BEGIN IF i = j THEN p := NIL ELSE 
BEGIN new{p); 
pt.left := tree(i, r[i,jJ-1); 
pt.pos t= trunc((lw-kin)*k/(n-1)) + (kIn DIV 2); kts k+7; 


pt.key := key[rLij]]; 
pt.right := tree(r[ij], j) 
END ; 
tree c= p 
END ; 


BEGIN k := 0; root := tree(O,n); 
current := root, roott.link := NIL; 
next := NIL; 
WHILE current # NIL DO 
BEGIN (*proceed down; first write vertical lines’) 
FOR i:= 1703 D0 
BEGIN u := 0; q := current; 
REPEAT ul := qt.pos; 
REPEAT write(" "); u c= u+4 


UNTIL u = ul; 
write(":"); u ts u+1; q t= qt.link 
UNTIL q = NIL; 
writen 
END ; 


(*now print master line; descending from nodes on current list 
collect their descendants and form next fist’) 
q := current; u t= 0; 
REPEAT unpack(qt.key, buf, 1); 
(*center key about pos*) i := kin; 
WHILE bul{i] =" " DO i:= i-1; 
u2 t= qt.pos - ((i-1) DIV 2); u3 c= u2+ti; 
qi := qt.left; q2 := qt.right; 
IF qi = NIL THEN ul ss u2 ELSE 
BEGIN uf := qit.pos; qit.link := next; next := qi 
END ; 
IF q2 = NIL THEN u4 := u3 ELSE 
BEGIN u4 := q2t.pos+1; q2t.link := next next := q2 
END ; 
i := O; 
WHILE u ¢ ul DO BEGIN write(" "); u t= ut+1 END ; 
WHILE u < u2 DO BEGIN wrile("-"); u ts u+1 END ; 
WHILE u < u3 DO BEGIN i := i+4; write(bul[i]); u:= u+1 END ; 
WHILE u <¢ u4 DO BEGIN write("-"); u ts ut END ; 


q t= qt.link 
UNTIL gq = NIL; 
writeln; 


(*now invert next list AND make it current list*) 
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current := NIL; 
WHILE next # NIL DO 
BEGIN q := next; next := qt.link; 
qt.link := current current := q 
END 
END 
END (‘printtree*) ; 


BEGIN (‘initialize table of keys. and counlers*) 


key[ 1] = "ARRAY "; key[ 2] := "BEGIN "; key[ 3] := "CASE" 
keyL 4] := "CONST "; key[ 5] t= "DIV"; key[ 6] := "DOWNTO "; 
key[ 7] := "DO "  keyL 8J cs "ELSE "; keyf 9] i= "END": 
key[ 10] :s "FILE "; key[11] := "FOR " key[12] := "FUNCTION “; 
key[13] := "GOTO "; key{14] := “IF we key[. 15] := "IN te 
key[ 16] := "LABEL "; key[17]:= "MOD"; key[ 18] := "NIL"; 
keyL 19] := "OF ms key[20]} := "PROCEDURE "; key[21] := "PROGRAM ”; 
key[22] := "RECORD "; key[23] := "REPEAT "; key[24]:= "SET "5 
key[25] := "THEN "; key[{26] := "TO - key[27]:= "TYPE "; 
key[28] := "UNTIL"; keyf29] := "VAR"; key[ 30] := "WHILE "; 
key 31] = 


"WITH "5 
FOR i := 1 TO n DO ; 
BEGIN afi] := 0; b[i] := 0 
END ; 
b[O] := 0; k2 := kin; 
(‘scan input text and determine a and b*) 
WHILE NOT eof{input) DO 
BEGIN read(ch); 
IF ch IN ["a".."z" ] THEN 
BEGIN (‘identifier or key’) k1 := 0; 
REPEAT IF ki < kin THEN 
BEGIN k1 := k1+1; buff{k1] <= ch 
END ; 
read(ch) 
UNTIL NOT (ch IN [“a".."z", "0".."9" J); 
IF k1 >= k2 THEN k2 := ki ELSE 
REPEAT bul{k2] := " "; k2 := k2-4 


UNTIL k2 = k1; 
pack(bul, 1,id); 
baaede pet 


REPEAT k := (i+j) DIV 2; 
IF key[k] <= id THEN i := k+4; 
IF keyLk]} >= id THEN j := k-1; 
UNTIL i > j; 
IF key[k] = id THEN a[k] c= afk] + 1 ELSE 
BEGIN k <= (i+j) DIV 2; b[k] := b[k]+t 
END ; 
END ELSE 
IF ch = """" THEN 
REPEAT read(ch) UNTIL ch = """" ELSE 
IF ch = "(*" THEN 
REPEAT read(ch) UNTIL ch 
END ; 
writeIn(" keys and frequencies of occurrence:"); 
suma := 0; sumb := b[0]; 
FOR i:= 1TOnDO 
BEGIN suma := suma+a{iJ; sumb := sumb+b[i]; 
writein(bli-1], afij, " ", key{i}) 
END ; 


way 
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writeln(b[n]); 
writeln(" 0 ------ weno "); 
writeln(sumb, suma); 


("compute w from a and b*) 
FOR i :+ 0 TOn DO 
BEGIN w[ii] := bli]; 
FOR j := i+ 1 TO n DO wf{ij] := wLij-1J + ali] + b£j] 
END ; 
writein; 
write(" average path length of balanced tree ="); 
writeln(baltree(O,n)/w[0,n]:6:3); printtree; 


opttree; 

writein; 

write(" average path length of optimal tree ="); 
writeln(pL0,n]/wL0,n]:6:3); printtree; 


(*now consider keys only, setting b = 0°) 
FOR i t= 0 FOn DO 
BEGIN wf[i,i] := 0; 
FOR j := i+1 TO n DO wij] := wfid-i] + aj] 
END ; 
opltree; 
writein; 
writeln(" optimal tree considering keys only"); 
printtree 
END . 
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11. Cross reference generators 


1. Read a text and generate a cross reference table of all words, i.e. sequences of 
characters that begin with a letter and consist of lellers and digits only. Blanks, ends 
of lines, and special characters are considered to be separators. Use a binary tree to 
store the words encountered. 


PROGRAM crossref(f,outpub); 

CONST ci = 10; ("length of words*) 
c2 8; (*numbers per line’) 
c3 6; (*digits per number’) 
c4 = 9999; (*max line number*) 

TYPE alfa = PACKED ARRAY [1..c1] OF char; 

wordref = tword; 
itemref = titem; 
word = RECORD key: alfa; 
first, last: itemref; 
left, right: wordref 


1H OR 


END ; 
item = PACKED RECORD 
Ino: 0..9999; 
next: itemref 
END ; 
VAR root: wordref; 
k,k1: integer; 
n: integer; (*current line number*) 
id: alfa; 
f: text 


a: ARRAY [t..c1] OF char; 


PROCEDURE search(VAR wt: wordref); 
VAR w: wordref; x: itemref; 
BEGIN w c= wt; 
IF w = NIL THEN 
BEGIN new(w); new(x); 
WITH wt.DO 
BEGIN key := id; left := NIL; right := NIL; 
first := x; last := x 
END ; 
xtdno is 1 xt.next := NIL; wi ss w 
END ELSE 
IF id < wt.key THEN search(wt.left) ELSE 
IF id > wt.key THEN search(wt.right) ELSE 
BEGIN new(x); xt.lno z= nj xt.next cs NIL; 
wt.laslt.next := x; wt.lasl := x 
END 
END (*search’*) ; 


PROCEDURE printtree(w: wordref); 


PROCEDURE printword(w: word); 
VAR I: integer; x: itemref; 
BEGIN write(" ", w.key); 


x ts w.first | t= 0; 
REPEAT IF | = c2 THEN 
BEGIN writeln; 


1 := 0; write(" ":c1+1) 
END ; | ; : 
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fits 1+; wrile(xt.Ino:c3); x i= xt.next 
UNTIL x = NIL; 
writein 
END (*printword*) ; 


BEGIN IF w # NIL THEN 
BEGIN printtree(wt Jeft); 
printword(wt); printtree(wt.right) 
END 
END (‘printtree*) ; 


BEGIN root := NIL; n t= 0; k1 := cf; 
page(output); resel(f); 
WHILE NOT eof(f) DO 
BEGIN IF n = c4 THEN n := 0; 
n t= n+1; write(n:c3); (*next line*) 
write(” "); ‘ 
WHILE NOT eoln(f) DO 
BEGIN (*scan non-empty fline*) 
IF ft IN ["a".."z"] THEN 
BEGIN k := 0; 
REPEAT IF k < cl THEN 
BEGIN k := k+1; afk] := ft; 
END ; 
write(ft); get(f) 
UNTIL NOT (ft IN ["a".."z","0".."9"]); 
IF k >= k1 THEN ki t= k ELSE 
REPEAT a[k1] z= ""; ki t= k1-1 


UNTIL ki = k; 
pack(a,1,id}; search(root) 
END ELSE 


BEGIN (*check for quote or comment’) 
IF ft = “""" THEN 
REPEAT write(ft); get(f) 
UNTIL ft = """" ELSE 
IF ft = "(€" THEN 
REPEAT write(ft); get(f) 
UNTIL ft = "}"; 
write(ft); get(f) 
END 
END ; 
writein; gel(f) 
END ; 


° 


page(output); printtree(root); 
ND. 
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2. Cross reference generator as above, bul using a hash table instead of a binary tree 
to store the words encountered. 


PROGRAM crossref(f,output); 
LABEL 13; 
CONST c1 = 10; (‘length of words*) 


c2 = 8; (*numbers per linet) 
c3 = 6; (‘digits per number’) 
c4 = 9999; (*max line number*) 


p = 997; (*prime number‘) 
free = " ms 
TYPE index = 0..p; 
itemref = titem; 
word = RECORD key: alfa; 
first, last: itemref; 
fol: index 
END ; 
item = PACKED RECORD 
Ino: 0..9999; 
next: itemref 
END ; 
VAR i, top: index; 
k,k1: integer; ‘ 
n: integer; (‘current line number‘) 
id: alfa; 
f: text; 
a: ARRAY [1..c1] OF char; 
letters, letdigs: SET OF char; 
t: ARRAY [0..p] OF word; (*hash table*) 


PROCEDURE search; 
VAR h,d,i: index: 
x: itemref; f: boolean; 
(*global variables: t, id, top*) 
BEGIN h := ord(id) DIV 4096 MOD p; 
(*Pascal-6000 defines ord on packed character array of length 10. 
Division is needed because division operates on 48 bits only! *) 
f := false; dis 1; 
new(x); xt.Ino t= nm; xt.next := NIL; 
REPEAT 
IF t(h].key = id THEN 
BEGIN (*found’) fF := true; 
t{h]Jastt.next := x; t{h]dast := x 
END ELSE : 
IF t((h].key = free THEN 
BEGIN (*new entry*) f := true; 
WITH t{h} DO 
BEGIN key := id; first := x; last := x; fol := top 
END ; 
top ish 
END ELSE 
BEGIN (*collision*) h := h+d; d := d42; 
IF h >= p THEN h c= h-p; 
IF d = p THEN 
BEGIN writeln(" table overflow"); GOTO 13 
END 
END 
UNTIL f 
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END (*search*) ; 


PROCEDURE oprinttable; 
VAR ij,m: index; 


PROCEDURE printword(w: word); 
VAR fk: integer; x: itemref; 
BEGIN write(" ", w.key); 
xX t= w.first: |= 0; 
REPEAT IF | = c2 THEN 
BEGIN writeln; 
t= QO; write(" “:c1+1) 
END ; 
t t= [+4; write(xt.Ino:c3); x := xt.next 
UNTIL x = NIL; 
writeln 
END (*printword*) ; 


BEGIN i := top; 
WHILE t # p DO 
BEGIN (*scan finked list and find minimal key*) 
mits ij ts tli fol; 
WHILE j # p DO 
BEGIN IF t[j].key < tlm].key THEN m := j; 
j t= t{j].fol 


printword(tLm]); 
IF m # i THEN 
BEGIN t{m].key := tLi].key; 
t(m].first := tCi].first; tim] last := t{i].last 
ND ; 
i:s t{i].fol 
END 

END (‘printtable*) ; 


BEGIN n is 0; k1 := c1; top t= p; reset(f); 
FOR i := 0 TO p DO I[i].key := free; 
letters := ["a’.."z"]; letdigs := letters + ["0".."9"]; 
WHILE NOT eof(f) DO 
BEGIN IF n = c4 THEN n := 0; 

n c= n+1; write({n:c¢3); (*next fine*) 
write(" "); 
WHILE NOT eoin(f) DO 
BEGIN (*scan non-empty line*) 
IF ft IN tetters THEN 
BEGIN k := 0; 
REPEAT IF k < ct THEN 
BEGIN k := k+1; ak] := ft; 
END ; 
write(ft); get(f) 
UNTIL NOT (ft IN letdigs); 
IF k >= kt THEN k1 := k ELSE 
REPEAT a[k1] t= """; ki ts ki-1 


UNTIL kt = k; 
pack(a,!,id); search; 
END ELSE 


BEGIN ¢*check for quote or comment*). 
IF ft = """" THEN 
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REPEAT write(ft); get(f) 
UNTIL ft = """" ELSE 
IF ft = "{(" THEN 
REPEAT write(ft); gel(f) 
UNTIL ft = "}"; 
write(ft); get(f) 
END 


END ; 
writeln; get(f) 
END ; 


13: page; printtable 
END . 
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12. Syntax analysis 


Skeleton compiler which checks the syntax of its input text according to the follawing 
grammar. Principle is top-down, recursive descent with one symbol lookahead. (see 
also N.Wirth, Algorilhms + Data Structures = Programs, Ch. 5, Prentice-Hall, Inc. 1975) 


program = block ".". 
block = [ "CONST" ident "=""number {"," ident "=" number} ";"] 
[ "VAR" ident ("," ident} ";" 
{ "PROCEDURE" ident ";" block ";"} statement . 
statement = [ ident ":s" expression | "CALL" ident | 
"BEGIN" statement (";" statement} "END" | 
"IF" condition "THEN" statement | 
"WHILE" condition "DO" statement J . 
condition = “ODD" expression | 
expression ("="["#""<"]' Cs" ["D"]" >=") expression . 
expression =["+"|"-"] term {("+"]"-") term). 
term = factor (("*"|"/") factor}. 
factor = ident | number | "(" expression ")" . 


PROGRAM PLO(input,outpul); 


LABEL 99; 

CONST norw = 11; (*no. of reserved words’*) 
txmax = 100; . (*length of identifier table*) 
nmax = 14; (*max. no of digits in numbers*) 
al = 10; (‘length of identifiers*) 


chsetsize = 128; (*for ASCII character set*) 


TYPE symbol = 
(nul ,identsnumber,plus,minus,times,slash,oddsym, 
eal,neq,|ss,leq,gtr,geq,|paren,rparen,comma,semicolon, ‘ 
period,becomes,beginsym,endsym,ifsym,thensym, 
whilesym,dosym,callsym,constsym,varsym,procsym); 
alfa = PACKED ARRAY [1..al] OF char; 
object = (constant,variable,prozedure); 


VAR ch: char; (*last character read*) 
sym: symbol; (*last symbol! read*) 
id: alfa; (“last identifier read*) 
num: integer; (‘last number read*) 
cc: integer; (*character count*) 

li: integer; (*line length*) 
kk: integer; 

line: ARRAY [1..81] OF char; 
a: alfa; 


word: ARRAY [1..norw] OF alfa; 
wsym: ARRAY [1..norw] OF symbol; 
ssym: ARRAY [char] OF symbol; 
table: ARRAY [0..txmax] OF 
RECORD name: alfa; 
kind: object 
END ; 
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PROCEDURE error(n: integer); 
BEGIN wrilteln(" "cc, "t", n:2); GOTO 99 
END (‘error’) ; 


PROCEDURE gelsym; 
VAR i,j,k: integer; 


PROCEDURE getch; 
BEGIN IF cc = Il THEN 
BEGIN IF eof(input) THEN 
BEGIN write(" program incomplete"); GOTO 99 
END ; 
I} := O; cco := O; write(" "); 
WHILE NOT eoln(input) DO 
BEGIN Ul ss tl+1; read(ch); write(ch); line[It] := ch 
END ; 
writein; tl ss +4; read(line[il}) 
END ; 
cc t= cc+1; ch := line[cc] 
END (*getch’) ; 


BEGIN (*getsym*) 
WHILE ch = "" DO getch; 
IF ch IN ["a".."z"] THEN 
BEGIN (‘identifier or reserved word”) k := 0; 
REPEAT IF k ¢ al THEN. 
BEGIN k := k+1; alk] := ch 
END ; 
getch 
UNTIL NOT (ch IN ["a".."z","0".."9" J); 
IF k >= kk THEN kk := k ELSE 
REPEAT afkk] := " "3 kk t= kk-1 
UNTIL kk = k; 
id ts a; tts 1; j t= norw; 
REPEAT k::= (i+j) DIV 2; 
IF id <= word[k] THEN j : 
IF id >= word[k] THEN i 
UNTIL i > j; 
IF i-t > j THEN sym := wsym[k] ELSE sym := ident 
END ELSE , 
IF ch IN ["O".."9"] THEN 
BEGIN (*number*) k := 0; num := 0; sym := number; 
REPEAT num := 10*num + (ord(ch)-ord("0")); 
k i= k+1; getch 
UNTIL NOT (ch IN ["0".."9"]); 
IF k > mmax THEN error(30) 
END ELSE 
IF ch = ":" THEN 
BEGIN getch; 
IF ch = "=" THEN 
BEGIN sym := becomes; getch 
END ELSE sym := nul; 
END ELSE 
IF ch = "<" THEN 
BEGIN getch; 


k-1; 
k+1 


wou 
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IF ch = "=" THEN 
BEGIN sym := leq; getch 
END ELSE sym := Iss 
END ELSE 
IF ch = ">" THEN 
BEGIN getch; 
IF ch = "=" THEN 
BEGIN sym := geq; getch 
END ELSE sym := gtr 
END ELSE 
BEGIN sym := ssym{ch]; getch 
END 
END (*getsym’*) ; 


PROCEDURE block(tx: integer); 


PROCEDURE enter(k: object); 
BEGIN (*enter object into table*) 
tx is tx + 13 
WITH table[tx] DO 
BEGIN name := id; kind := k; 
END 
END (*enter*) ; 


FUNCTION position(id: alfa): integer; 


VAR i: integer; 

BEGIN (‘find identifier id in table’) 
table[O].name := id; i t= tx; 
WHILE table[i].name # id DO i := i-1; 
position := i 


END (*position’*) ; 


PROCEDURE constdecliaration; 
BEGIN IF sym = ident THEN 
BEGIN getsym; 
IF sym = eq! THEN 
BEGIN getsym; 
IF sym = number THEN 
BEGIN enter(constant); getsym 
END 
ELSE error(2) 
END ELSE error({3) 
END ELSE error(4) 
END (*constdeclaralion*) ; 


PROCEDURE vardeciaration; 

BEGIN IF sym = ident THEN 
BEGIN enter(variable); getsym 
END ELSE error(4) 

ENO (*vardeciaration*) ; 


PROCEDURE statement; 
VAR i: integer; 
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PROCEDURE expression; 
PROCEDURE term; 


PROCEDURE factor; 
VAR i: integer; 
BEGIN 
IF sym = ident THEN 
BEGIN i := position(id); 
IF i = O THEN error(11) ELSE 
IF table[{i].kind = prozedure THEN error(21); 
gelsym 
END ELSE 
IF sym = number THEN 
BEGIN getsym 
END ELSE 
IF sym = Iparen THEN 
BEGIN getsym; expression; 
IF sym = rparen THEN getsym ELSE error(22) | 
END 
ELSE error(23) 
END (*factor*) ; 


BEGIN (*term*) factor; 
WHILE sym IN [times,slash}] DO 
BEGIN getsym; factor 
END 
END (*term’) ; 


BEGIN (‘expression’) 
IF sym IN [plus,minus} THEN 
BEGIN getsym; lerm 
END ELSE term; 
WHILE sym IN [plus,minus] DO 
BEGIN getsym; term 
END 
END (*expression’) ; 


PROCEDURE condition; 
BEGIN 
IF sym = oddsym THEN 
BEGIN getsym; expression 
END ELSE 
BEGIN expression; 
IF NOT (sym IN [eql,neq,iss,leq,glr,geq]) THEN 
error(20) ELSE 
BEGIN getsym; expression 
END 
END 
END (*condition*) ; 


BEGIN (*stalement*) 
IF sym = ident THEN 
BEGIN i := posilion(id); 
IF ji = O.THEN error(11) ELSE 
IF table[i].kind # variable THEN error(12); 
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getsym; IF sym = becomes THEN getsym ELSE error(13); 
expression 
END ELSE 
IF sym = callsym THEN 
BEGIN getsym,; 
IF sym # ident THEN error(14) ELSE 
BEGIN i := position(id); 
IF i = O THEN error(11) ELSE 
IF table[i].kind # prozedure THEN error(15); 


END ELSE 
IF sym = ifsym THEN 
BEGIN getsym; condition; 
IF sym = thensym THEN getsym ELSE error(16); 
statement; : 
END ELSE 
IF sym = beginsym THEN 
BEGIN getsym; statement; 
WHILE sym = semicolon DO 
BEGIN getsym; statement 
END ; 
IF sym = endsym THEN getsym ELSE error(17) 
END ELSE 
IF sym = whilesym THEN 
BEGIN getsym; condition; 
IF sym = dosym THEN getsym ELSE error(18); 
statement 
END 
END (*statement*) ; 


BEGIN (*block*) 
IF sym = conslsym THEN 
BEGIN getsym; constdeclaration; 
WHILE sym = comma DO 
BEGIN getsym; constdeclaration 
END ; 
IF sym = semicolon THEN getsym ELSE error(5) 
END ; 
IF sym = varsym THEN 
BEGIN getsym; vardeclaration; 
WHILE sym = comma DO 
BEGIN getsym; vardeclaration 
END ; 
IF sym = semicolon THEN getsym ELSE error(5) 
END ; 
WHILE sym = procsym DO 
BEGIN getsym; 
IF sym = ident THEN 
BEGIN enler(prozedure); gelsym 
END 
ELSE error(4.); 
IF sym = semicolon THEN getsym ELSE error(5); 
block(tx); 
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iF sym = semicolon THEN gelsym ELSE error(5); 
END ; 


statement 
END (*block*) ; 


BEGIN (*main program’) 


FOR ch := chr(O) TO chr(chsetsize-1) DO ssym[ch] := nul; 


word. 1] := "BEGIN "; wordi 2} := "CALL i 
word 3] := "CONST Ki wordt, 4] := "DO me 
word 5] := "END "word! 6] := "IF " 
word, 7] := "ODD " word[ 8] := "PROCEDURE ie 
word[ 9] := "THEN ": word[ 10] := "VAR i 
word[11] := “WHILE 

wsym[ 1] := beginsym; wsym[ 2] := callsym; 

wsym[ 3] := constsym; wsym[ 4] := dosym; 

wsym[ 5] := endsym; wsym[ 6] := ifsym; 

wsym{ 7] := oddsym; wsym[ 8] := procsym; 
wsym[ 9] := thensym; wsym[10] := varsym; 


wsym[ 11] := whilesym; 
ssym["+"] := plus; = ssym["-"] := minus; 
‘ ssym{"*"] t= times; ssym["/"] := slash; 


ssym["("] := Iparen; ssym[")"] := rparen; 
ssym["="] := eql; ssym["," J := comma; 
ssym["."] := period; ssym["#"] := ae 
ssym["<"] := Iss; ssym[">"] t= 
ssym[";"] := semicolon; 
page(output); 
cco is 0; Il t= O; ch t= " "5 kk t= ak gelsym; 
block(0); 
IF sym # period THEN error(9); 

99: writeln 


END . 


73 


Berichte des Instituts fiir Informatik 


Nr. 


Nr. 


* Nr. 
* Nr. 
Nr. 
* Nr. 
Nr. 
Nr. 


* Nr. 
*Nr. 


Nr. 


*Nr. 


Nr. 
Nr. 
Nr. 


1 
2 
o3 
4 


on 


. Wirth 
. Wirth 
. Lauchli 


. Gander, 
. Mazzario 


N 

N 

P 

W 

A 

N. Wirth 
C.A.R.Hoare, 
N,. Wirth 
W 

A 

E 

E 

E 

H 


. Gander, 
. Mazzario 


. Engeler, 
. Wiedmer, 
. Zachos 


.P. Frei 


.V. Nori, 
. Ammann, 
Jensen, 
-H. Nageli, 
h. Jacobi 


-I. Ugron, 
oR. Liithi 


Wirth 
Ammann 
.Lieberherr 
Engeler 

. Bucher 

. Wirth 


2 2 mM KR COC Fe TAM NOAA CK 


N. Wirth 
N. Wirth 


E. Wiedmer 


J.Nievergelt, 
H.P. Frei, 
et al. 


P, Lauchli 
K. Bucher 
E, Engeler 


The Programming Language PASCAL 
Program development by step-wise refinement 
Reduktion elektrischer Netzwerke und Gauss'sche Elimination 


Numerische Prozeduren I 
The Programming Language PASCAL (Revised Report) 


An Axiomatic Definition of the Language PASCAL 


Numerische Prozeduren II 


Ein Einblick in die Theorie der Berechnungen 


Computer Aided Instruction: The Author Language and 
the System THALES 


The Pascal "P' Compiler: Implementation Notes 
(Revised Edition) 


Das Informations-System ELSBETH 


PASCAL-S: A subset and its Implementation 

Code Generation in a PASCAL Compiler 

Toward Feasible Solutions of NP-Complete Problems 
Structural Relations between Programs and Problems 
A contribution to solving large linear problems 


Programming languages: what to demand and how to 
access them and 
Professor Cleverbyte's visit to heaven 


MODULA: A language for modular multiprogramming 


The use of MODULA and 
Design and Implementation of MODULA 


Exaktes Rechnen mit reellen Zahlen 
XS-0, a Self-explanatory School Computer 


Ein Problem der ganzzahligen Approximation 
Automatisches Zeichnen von Diagrammen 
Generalized Galois Theory and its Applicationto Complexity 


Nr. 


Nr. 
Nr. 
.28 


Nr 


Nr. 


Nr. 


Nr. 
Nr. 
Nr. 


25 


26 
27 


29 


30 


31 
32 
33 


(om 


> 


> OW 


= Mm 


aa 2z Mm 


Ammann 


Zachos 
. Wirth 


Weydert 
.C. Shaw 


.Thurnherr, 
.A. Zehnder 


.C. Shaw 
. Engeler 
. Wirth 


* out of print 


.Nievergelt 


Error Recovery in Recursive Descent Parsers and 
Run-time Storage Organization 


Kombinatorische Logik und S-Terme 

MODULA-2 

*Sites, Modes and Trails: Telling the User of an Interactive 
System where he is, what he can do, and how to get to Places 
On the Specification of Graphic Command Languages and 

their Processors 

Global Data Base Aspects, Consequences for the Relational 
Model and a Conceptual Scheme Language 

Software Specification Languages based on regular Expressions 
Algebras and Combinators 

A Collection of PASCAL Programs 


